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..7be3f8c3 --- /dev/null +++ b/formal/sphincs/README.md @@ -0,0 +1,555 @@ +# SPHINCS security statement + +This Lean project states, and does not yet prove, the classical random-oracle security of the concrete SPHINCS instance specified by `doc/sphincs/main.tex` and implemented by `crates/sphincs`: `SphincsSecurityStatement`, which reads `HasClassicalSecurityBits Concrete.scheme 120`. + +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 is what a proof here would extend. + +## 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 specification's seed derivation and the signer's cache are implementations of this key and change no probability. 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. + +## Why 120 bits and not 128 + +The bound is the slope `q / 2^bits`, so it bounds what one query buys. Every strategy the specification accounts for costs `2^-128` per query: inverting a chain step, a node or a leaf, recovering a published secret, or grinding a counter onto an already signed codeword, each separated from the others by its tweak, so no query bears on two structural positions and no multi-target factor appears. The few-time leak is at most `2^-122` at `q_s = 2^24` (the exact count is about `2^-122.9`), so it does not bind once the mandatory signing work is included; it is what fixes `signatureLimit`, reaching `2^-128` at `2^25.1` signatures and `2^-120` at `2^26.4`, about two doublings of headroom. Read the claim where an adversary spending all `2^24` signatures lives: the query bound counts every execution path, so the `2^32` attempt caps put the floor at `q = 2^58`, where the bound reads `2^-62` against a true forging probability of about `2^-70`. The slack is that same `2^8` at every `q`, the dominant term being linear in it. Claiming 120 leaves `2^8` for the union bounds and constants a proof accumulates, where XMSS could claim 127 against the same digest length with one hash chain layer and one tree. + +## Status + +## 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. + +## What remains + +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, so the conservative final accounting now targets `c = 9`, with `2 * c + 1 = 19`. 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 remaining probability step proves the weighted one-guess bound directly for this root-aware selector. The existing `RootHiddenRelates` probe rule has the required symmetry: every additional safe probe adds the same pending candidate in both swapped-root worlds, while either distinguished-root candidate stops before execution. The successful observed support condition must then exclude every frozen failure before its selected ordinal. After this fixed-ordinal lemma, the implementation order is: combine the existing root and non-root ordinal endpoints; sum only the source ordinals that can exist; close the granular private bound; reuse the existing boundary and terminal arithmetic; finally replace the public theorem's sole `sorry`. 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 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. The safe nonselected hash branch is now compiled: if the appended observation is hit-free and its probe avoids the resolved target value, installing that value preserves the event-relevant trace, and the complete retained continuation has the same Boolean distribution. The remaining hash branch is precisely the unsafe appended candidate. Pointwise trace equality is false there; instead, the prefix gate makes every later selected ordinal false once that resolved value is fixed, so the normalization induction must eliminate that branch at the sampler level. This is an accounting correction, not a change to the game or security claim. + +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` reports the `sorry` in `SphincsSecurity.lean`, which is the open goal, and nothing else. diff --git a/formal/sphincs/SphincsSecurity.lean b/formal/sphincs/SphincsSecurity.lean new file mode 100644 index 00000000..fceba2e3 --- /dev/null +++ b/formal/sphincs/SphincsSecurity.lean @@ -0,0 +1,16 @@ +import SphincsSecurity.Statement +import SphincsSecurity.Proof + +namespace SphincsSecurity + +/-! +The claim to be proven. Its statement lives entirely in the single module `SphincsSecurity.Statement`, whose parameters, algorithms and experiment are the specification of `doc/sphincs/main.tex`. + +The `sorry` below is the whole point of this project: it is the goal, and the build says out loud that nothing proves it yet. `formal/xmss` proves the analogous claim for the stateful scheme, and the two share the tweakable hash, the target-sum code and the shape of the bound, so the one-time and Merkle halves of that proof carry over; what is new here is the hypertree, the few-time forest, the digest that picks the index, and the counter search under a tweak shared across attempts. +-/ + +/-- `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 + sorry + +end SphincsSecurity diff --git a/formal/sphincs/SphincsSecurity/Proof.lean b/formal/sphincs/SphincsSecurity/Proof.lean new file mode 100644 index 00000000..bc5d0f6a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof.lean @@ -0,0 +1,302 @@ +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.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.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveLift +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveAfterRoot +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalize +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootJoint + +/-! +The proof of `SphincsSecurityStatement`, in progress. Only `SphincsSecurity/Statement.lean` has to +be trusted; everything here is checked by Lean. + +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/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..c92dc23e --- /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, ?_⟩ + native_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/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/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/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/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/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..71f2ff40 --- /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 ^ 121 : 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 ^ 120) (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 ^ 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 ^ 121 : 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/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/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..af9dcda0 --- /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 ^ 120) + (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 ^ 120) + (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 ^ 120) + (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 ^ 120) + (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 ^ 120) + (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 ^ 120) + (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..c4a7bfe2 --- /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 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..7b9394ee --- /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 ^ 120) (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 ^ 120) (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/FewTimePatterns.lean b/formal/sphincs/SphincsSecurity/Proof/FewTimePatterns.lean new file mode 100644 index 00000000..fb23dcfd --- /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 native_decide + +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..c6642139 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/FewTimeRace.lean @@ -0,0 +1,548 @@ +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) + +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 ^ 121 : 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 ^ 7 : 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_two_neg_seven + 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 ^ 121 : 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 ^ 121 : 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 ^ 121 : 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 ^ 121 : 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 ^ 121 : 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 ^ 121 : 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 ^ 121 : Nat) : ℝ≥0∞) := by + norm_num [digestAttemptLimit] + +end SphincsSecurity 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/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..6a84bb8d --- /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 ^ 120) (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 ^ 120) + (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 ^ 120) + (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 ^ 120) + (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 ^ 120) + (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 ^ 120) + (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 ^ 120) + (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..040fd2b3 --- /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 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/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/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/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/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/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/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/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/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/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/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/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/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/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/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..72f6ea84 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedAdaptiveBridge.lean @@ -0,0 +1,675 @@ +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) + [ObserverPositionNeutral table 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 ObserverPositionNeutral.eq_resolve + (table := table) (observe := observe) position + (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 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/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..9bd0b6dd --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateCount.lean @@ -0,0 +1,253 @@ +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_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 + +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..6d12edde --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivatePlanNormalizedCount.lean @@ -0,0 +1,158 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivatePlanNormalized + +/-! +# 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 + +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 + +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..b16734ec --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinal.lean @@ -0,0 +1,197 @@ +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 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..818fcae1 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassification.lean @@ -0,0 +1,559 @@ +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 : ∀ root, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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..3c1a94d9 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationKernel.lean @@ -0,0 +1,148 @@ +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, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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..926e0449 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationProjection.lean @@ -0,0 +1,274 @@ +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.SuccessfulDoomedFirstExistingHiddenRootHitAt + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) : + Option (ObservedCleanRunResult α) → Prop + | none => False + | some result => + (∃ finalResult, some finalResult ∈ support + (finishObservedCleanRunFromTable (some result))) ∧ + ¬DeferredCompletable table (directDeferredContext result.state) ∧ + ObservedCleanRunOption.FirstExistingHiddenRootHitAt ordinal (some result) + +def ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenNonRootHitAt + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) : + Option (ObservedCleanRunResult α) → Prop + | none => False + | some result => + (∃ finalResult, some finalResult ∈ support + (finishObservedCleanRunFromTable (some result))) ∧ + ¬DeferredCompletable table (directDeferredContext result.state) ∧ + 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.SuccessfulDoomedFirstExistingHiddenRootHitAt 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⟩, hdoomed, + ⟨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.SuccessfulDoomedFirstExistingHiddenNonRootHitAt 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⟩, hdoomed, + ⟨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.SuccessfulDoomedFirstExistingHiddenRootHitAt 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.SuccessfulDoomedFirstExistingHiddenRootHitAt 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.SuccessfulDoomedFirstExistingHiddenNonRootHitAt 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.SuccessfulDoomedFirstExistingHiddenNonRootHitAt 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..f024955e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationSample.lean @@ -0,0 +1,285 @@ +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 : ∀ root, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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 + +theorem probEvent_sampledCanonical_root_le_diagnostic + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ root, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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..957b8c8a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedAlignedProjection.lean @@ -0,0 +1,219 @@ +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, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash q) + (hq : q ≤ 2 ^ securityBits) : + Pr[ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenNonRootHitAt 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.SuccessfulDoomedFirstExistingHiddenNonRootHitAt 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.SuccessfulDoomedFirstExistingHiddenNonRootHitAt] at hevent + | some result => + obtain ⟨⟨finalResult, hfinish⟩, _hdoomed, 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 : ∀ root, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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 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..33088e72 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedLift.lean @@ -0,0 +1,1347 @@ +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 : computation.IsQueryBoundP IsOuterHash 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 [OracleComp.isQueryBoundP_query_bind_iff] at hbound + rw [directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve, + OracleComp.construct_query_bind, observedMaterializedBoundary, + OracleComp.construct_query_bind] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + 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 => + 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 houter).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 => + simp only + let leftObserve : DeferredContext → Nat → + ((OracleWorld + SigningSpec).Range (.inr message) × 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 (.inr message) × SplitHashCache)) := + runDirectResolvedWitnessFromTable left leftFuel table + ((maskedSign parameter root ftsSecret message).run leftCache) + let rightStep : ProbComp (Option (ObservedCleanRunResult + ((OracleWorld + SigningSpec).Range (.inr message) × 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 + (α := (OracleWorld + SigningSpec).Range (.inr message)) + (β := 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] + simpa [leftObserve, IsOuterHash] using + (ih nextLeft.value.1 snapshots observations canonical nextRight.context + nextLeft.remaining nextRight.remaining nextLeft.value.2 nextRight.value.2 bound + (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) + 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..eb36ed4f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedProbability.lean @@ -0,0 +1,320 @@ +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, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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 => + 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 + adversary parameter table ftsSecret canonical resolved.remaining resolved.value + [] q (hbound resolved.value.1) (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 : ∀ root, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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 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 : ∀ root, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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) (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) + (hbound : ∀ root, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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 hbound 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) hbound (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) + (hbound : ∀ root, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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 hbound 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) + (hbound : ∀ root, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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 hbound (by omega) + · exact probEvent_sampledDiagnostic_successfulDoomed_le_of_selected_ordinals_bound + adversary parameter ftsSecret q hbound 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) + (hbound : ∀ root, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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 hbound 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) + (hbound : ∀ root, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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 hbound 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..a1ec3c94 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedProjection.lean @@ -0,0 +1,168 @@ +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, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash q) + (hq : q ≤ 2 ^ securityBits) : + Pr[ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt 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.SuccessfulDoomedFirstExistingHiddenRootHitAt] at hevent + | some result => + obtain ⟨⟨finalResult, hfinish⟩, _hdoomed, 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, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash q) + (hq : q ≤ 2 ^ securityBits) : + Pr[ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenNonRootHitAt 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.SuccessfulDoomedFirstExistingHiddenNonRootHitAt 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.SuccessfulDoomedFirstExistingHiddenNonRootHitAt] at hevent + | some result => + obtain ⟨⟨finalResult, hfinish⟩, _hdoomed, _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, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash q) + (hq : q ≤ 2 ^ securityBits) : + Pr[fun observed => + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt table ordinal + observed ∨ + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenNonRootHitAt 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.SuccessfulDoomedFirstExistingHiddenRootHitAt table ordinal observed ∨ + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenNonRootHitAt 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.SuccessfulDoomedFirstExistingHiddenRootHitAt] at hroot + | some result => + obtain ⟨⟨finalResult, hfinish⟩, _hdoomed, 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.SuccessfulDoomedFirstExistingHiddenNonRootHitAt] at hnonRoot + | some result => + obtain ⟨⟨finalResult, hfinish⟩, _hdoomed, _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..235bccfc --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRoot.lean @@ -0,0 +1,169 @@ +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, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash q) + (hq : q ≤ 2 ^ securityBits) : + Pr[ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt 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.SuccessfulDoomedFirstExistingHiddenRootHitAt] at hevent + | some result => + obtain ⟨⟨finalResult, hfinish⟩, _hdoomed, 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..9e7bed18 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveAfterRoot.lean @@ -0,0 +1,143 @@ +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 : (retainedGameRestComputation adversary + ⟨rootResult.value.1, parameter⟩).IsQueryBoundP IsOuterHash 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/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveLift.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveLift.lean new file mode 100644 index 00000000..d754d949 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveLift.lean @@ -0,0 +1,2892 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdministrative +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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] 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⟩, _hrightDoomed, 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⟩, + hleftDoomed leftResult (by simpa [leftRun] using hleftSupport), 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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⟩, _hdoomed, + 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⟩, _hdoomed, + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] at hgood + | some result => + obtain ⟨⟨⟨⟨_finalResult, _hfinish⟩, _hdoomed, + _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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] 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.SuccessfulDoomedFirstRootGoodForComparisonAt + table ordinal target rightRoot observed := by + rw [successfulObservedRootComparisonIndicator_eq_true_iff] at htrue + exact htrue + cases observed with + | none => + simp [ObservedCleanRunOption.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] at hgood + | some result => + have hsourceOutput : sourceOutput = (none, nextSnapshots) := by + simpa [source] using hrelation.2 + subst sourceOutput + obtain ⟨⟨⟨⟨finalResult, hfinish⟩, _hdoomed, + 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 : computation.IsQueryBoundP IsOuterHash 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 => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + 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 [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 => + 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 [IsOuterHash])).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 : selectedComputation.IsQueryBoundP IsOuterHash bound := by + unfold selectedComputation + rw [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 (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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] + 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 + ((probingHashQueryAfterPlan 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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] + | 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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] + | 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 houter).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 + ((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 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 + ((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 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 + ((probingHashQueryAfterPlan 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, plan.candidate? = some candidate → + candidate ∈ nextSnapshots.map PlannedProbeSnapshot.toProbe := by + intro candidate hcandidate + rw [hnextCandidates] + have hrecorded := + rootAwarePlannedCandidate?_eq_of_plan_some hcandidate + have hcandidateRoot : candidate? = some candidate := by + simpa [candidate?, plan, rootAwareCandidateForPlan?_purePlan] using + hrecorded + simp [appendPlannedCandidate, hcandidateRoot] + have hprobeBound := probingHashQueryAfterPlan_probeBound 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) + ((probingHashQueryAfterPlan parameter input plan).run leftCache) left + leftFuel table nextLeft hcoveredAtStart hprobeBound + rw [← map_erase_runDirectResolvedWitnessFromTable + ((probingHashQueryAfterPlan 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_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 [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_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 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, hrightFuelEq] 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_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 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, hrightFuelEq] 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 => + 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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] + | 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] + 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) + +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..9ff30d4c --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveNormalize.lean @@ -0,0 +1,1384 @@ +import SphincsSecurity.Proof.OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveTrace +import SphincsSecurity.Proof.OtsProbeResolvedPrivateRetainedCommutation + +/-! +# 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 + +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)] + [ObserverPositionNeutral 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 + 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⟩ + 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 (runResolvedObserve nextObserve left fuel table computation) := + (evalDist_runResolvedObserve_eq_runDirectResolvedObserve + (observe := nextObserve) left fuel table computation hleftValid hleftCompletable).symm + _ = evalDist (runResolvedObserve nextObserve right fuel table computation) := + evalDist_runResolvedObserve_eq_of_finalizationSynchronized computation left right fuel table + ⟨hview, hleftValid, hrightValid, hleftCompletable⟩ hvalues hrevealed + _ = evalDist (runDirectResolvedObserve nextObserve right fuel table computation) := + evalDist_runResolvedObserve_eq_runDirectResolvedObserve + (observe := nextObserve) right fuel table computation hrightValid hrightCompletable + _ = _ := + (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 + +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 + ((probingHashQueryAfterPlan 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 + ((probingHashQueryAfterPlan 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 + ((probingHashQueryAfterPlan 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))) + ((probingHashQueryAfterPlan 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/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..63d8c3ee --- /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.SuccessfulDoomedFirstRootGoodForComparisonAt + table ordinal target rightRoot observed) : + ObservedCleanRunOption.SuccessfulDoomedFirstRootGoodForComparisonAt + table ordinal target rightRoot (retainObservedRoot root observed) := by + cases observed with + | none => + simp [ObservedCleanRunOption.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] at hgood + | some result => + simp only [retainObservedRoot] + rcases hgood with ⟨⟨⟨hfinish, hdoomed, hfirst⟩, hposition⟩, havoid⟩ + refine ⟨⟨⟨?_, hdoomed, ?_⟩, ?_⟩, ?_⟩ + · 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.SuccessfulDoomedFirstRootGoodForComparisonAt + table ordinal target rightRoot (retainObservedRoot root observed)) : + ObservedCleanRunOption.SuccessfulDoomedFirstRootGoodForComparisonAt + table ordinal target rightRoot observed := by + cases observed with + | none => + simp [retainObservedRoot, + ObservedCleanRunOption.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] at hgood + | some result => + simp only [retainObservedRoot] at hgood + rcases hgood with ⟨⟨⟨hfinish, hdoomed, hfirst⟩, hposition⟩, havoid⟩ + refine ⟨⟨⟨?_, hdoomed, ?_⟩, ?_⟩, ?_⟩ + · 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.SuccessfulDoomedFirstRootGoodForComparisonAt + table ordinal target rightRoot (retainObservedRoot root observed) ↔ + ObservedCleanRunOption.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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 + ((probingHashQueryAfterPlan 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 + ((probingHashQueryAfterPlan 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/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveTrace.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdaptiveTrace.lean new file mode 100644 index 00000000..63289c1a --- /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.SuccessfulDoomedFirstRootGoodForComparisonAt + table ordinal target rightRoot left ↔ + ObservedCleanRunOption.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] + rw [hfinish, hstate, 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 + ((probingHashQueryAfterPlan 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..e80b4df6 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAdministrative.lean @@ -0,0 +1,1304 @@ +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 + +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 : computation.IsQueryBoundP IsOuterHash bound) + (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 [OracleComp.isQueryBoundP_query_bind_iff] at hbound + 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 : ∀ output, (next output).IsQueryBoundP IsOuterHash 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] + exact ih leftResult.value.1 leftResult.observations leftResult.state + leftResult.remaining rightResult.remaining tailBound leftResult.value.2 + (htailBound leftResult.value.1) (by omega) (by omega) + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + change Fin (n + 1) → OracleComp (OracleWorld + SigningSpec) α at next + simp only + have htail : ∀ output, (next output).IsQueryBoundP IsOuterHash bound := by + intro output + simpa [IsOuterHash] using hbound.2 output + 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 => + change HashOutput → OracleComp (OracleWorld + SigningSpec) α at next + simp only + have hpositive : 0 < bound := by + rcases hbound.1 with hnot | hpositive + · exact (hnot (by simp [IsOuterHash])).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 : ∀ output, (next output).IsQueryBoundP IsOuterHash (bound - 1) := by + intro output + simpa [IsOuterHash] using hbound.2 output + 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 => + change Option Signature → OracleComp (OracleWorld + SigningSpec) α at next + simp only + have htail : ∀ output, (next output).IsQueryBoundP IsOuterHash bound := by + intro output + simpa [IsOuterHash] using hbound.2 output + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + table ordinal target rightRoot (some left)) : + ObservedCleanRunOption.SuccessfulDoomedFirstRootGoodForComparisonAt + 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, hdoomed, 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 + have hrightDoomed : + ¬DeferredCompletable table (directDeferredContext right.state) := by + rw [← hstate] + exact hdoomed + exact ⟨⟨⟨hrightFinish, hrightDoomed, 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.SuccessfulDoomedFirstRootGoodForComparisonAt + table ordinal target rightRoot (some left)) : + ObservedCleanRunOption.SuccessfulDoomedFirstRootGoodForComparisonAt + table ordinal target rightRoot (some right) := by + rcases hrel with ⟨hstate, htable, _hvalue, hobservations⟩ + rcases hgood with + ⟨⟨⟨hfinish, hdoomed, hfirstRoot⟩, hposition⟩, hcomparison⟩ + have hrightFinish := exists_finishObservedCleanRunFromTable_of_state_table_eq + left right hstate htable hfinish + have hrightDoomed : + ¬DeferredCompletable table (directDeferredContext right.state) := by + rw [← hstate] + exact hdoomed + 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, hrightDoomed, 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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] 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 : computation.IsQueryBoundP IsOuterHash bound) + (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 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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] 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..922f49db --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootAwareExperiment.lean @@ -0,0 +1,72 @@ +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 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 ← runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + 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 ← runCleanFromTable + (LazyRevealProbe.State.empty : LazyRevealProbe.State Coordinate) fuel table + (maskedPublishedTreeRoot.run emptySplitHashCache) + 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..bcd7d4e4 --- /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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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⟩, _hdoomed, + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + table ordinal target rightRoot (some result)) : + (MaterializedSelectionOutcome.finished + (some (candidates.get ⟨ordinal, hselected⟩))).Matches target leftRoot := by + have hgood' := hgood + obtain ⟨⟨⟨⟨_finalResult, _hfinish⟩, _hdoomed, + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + table ordinal target rightRoot (some result)) : False := by + obtain ⟨⟨⟨⟨finalResult, hfinish⟩, _hdoomed, + _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.SuccessfulDoomedFirstRootGoodForComparisonAt + table ordinal target rightRoot (some result)) : False := by + obtain ⟨⟨⟨⟨_finalResult, _hfinish⟩, _hdoomed, + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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⟩, _hdoomed, + _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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] 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⟩, _hdoomed, + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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⟩, _hdoomed, + 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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] 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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] + 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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] + 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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] + 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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] + 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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] + 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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] + 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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] 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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] + 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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + rootResult.table ordinal target rightRoot pair.1 := by + cases hpairFirst : pair.1 with + | none => + rw [hpairFirst] at hgood + simp [retainObservedRoot, + ObservedCleanRunOption.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] at hgood + | some result => + rw [hpairFirst] at hgood + simp only [retainObservedRoot] at hgood + rcases hgood with ⟨⟨⟨hfinish, hdoomed, hfirst⟩, hposition⟩, havoid⟩ + refine ⟨⟨⟨?_, hdoomed, ?_⟩, ?_⟩, ?_⟩ + · 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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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..c207bfd0 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootJoint.lean @@ -0,0 +1,806 @@ +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.SuccessfulDoomedFirstRootHitAtTarget + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) (target : Position) + (observed : Option (ObservedCleanRunResult α)) : Prop := + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt + table ordinal observed ∧ + observedFirstLayerRootPosition? ordinal observed = some target + +theorem successfulDoomedFirstRootHitAtTarget_root + {table : OtsSecretIndex → HashOutput} {ordinal : Nat} {target : Position} + {observed : Option (ObservedCleanRunResult α)} + (hhit : ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget + table ordinal target observed) : + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt + table ordinal observed := + hhit.1 + +theorem observedFirstLayerRootPosition?_eq_some_of_successfulDoomedFirstRoot + {table : OtsSecretIndex → HashOutput} {ordinal : Nat} + {observed : Option (ObservedCleanRunResult α)} + (hhit : ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt + table ordinal observed) : + ∃ target, observedFirstLayerRootPosition? ordinal observed = some target := by + cases observed with + | none => simp [ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] at hhit + | some result => + obtain ⟨_hfinish, _hdoomed, 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.SuccessfulDoomedFirstExistingHiddenRootHitAt + 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.SuccessfulDoomedFirstRootHitAtTarget + table ordinal target observed | run] ≤ + Pr[fun observed => observedFirstLayerRootPosition? ordinal observed = some target | run] * + ((2 ^ digestBits : Nat) : ENNReal)⁻¹) : + Pr[fun observed => + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt + table ordinal observed | run] ≤ + ((2 ^ digestBits : Nat) : ENNReal)⁻¹ := by + apply probEvent_le_of_uniform_weighted_fibers run + (ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt table ordinal) + (observedFirstLayerRootPosition? ordinal) + (((2 ^ digestBits : Nat) : ENNReal)⁻¹) + intro position? + cases position? with + | none => + have hzero : Pr[fun observed => + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (target : Position) (rightRoot : Digest) + (observed : Option (ObservedCleanRunResult α)) : Prop := + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget + table ordinal target observed ∧ + CandidatesAvoidRoot target rightRoot (observedPrefixProbes ordinal observed) + +def ObservedCleanRunOption.SuccessfulDoomedFirstRootComparisonExceptionAt + (table : OtsSecretIndex → HashOutput) (ordinal : Nat) + (target : Position) (rightRoot : Digest) + (observed : Option (ObservedCleanRunResult α)) : Prop := + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget + 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.SuccessfulDoomedFirstRootHitAtTarget + table ordinal target observed) : + ObservedCleanRunOption.SuccessfulDoomedFirstRootGoodForComparisonAt + table ordinal target rightRoot observed ∨ + ObservedCleanRunOption.SuccessfulDoomedFirstRootComparisonExceptionAt + 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.SuccessfulDoomedFirstRootComparisonExceptionAt + table ordinal target result.2 result.1 | do + let observed ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)] ≤ + Pr[fun observed => ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget + table ordinal target observed | run] * + ((ordinal : ENNReal) * ((2 ^ digestBits : Nat) : ENNReal)⁻¹) := by + let gate := fun observed : Option (ObservedCleanRunResult α) => + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget + 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.SuccessfulDoomedFirstRootHitAtTarget + table ordinal target observed | run] ≤ + Pr[fun result : Option (ObservedCleanRunResult α) × Digest => + ObservedCleanRunOption.SuccessfulDoomedFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | do + let observed ← run + let rightRoot ← ($ᵗ Digest : ProbComp Digest) + pure (observed, rightRoot)] + + Pr[fun observed => ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 ∨ + ObservedCleanRunOption.SuccessfulDoomedFirstRootComparisonExceptionAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + table ordinal target result.2 result.1 | paired] + + Pr[fun result => + ObservedCleanRunOption.SuccessfulDoomedFirstRootComparisonExceptionAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + table ordinal target rightRoot observed) : + SelectedPrivateSnapshotCleanRootGoodForComparisonAt + table source ordinal target rightRoot := by + cases observed with + | none => + simp [ObservedCleanRunOption.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] at hgood + | some result => + obtain ⟨⟨⟨⟨finalResult, hfinish⟩, _hdoomed, + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash q) + (hq : q ≤ 2 ^ securityBits) : + Pr[fun result : Option + (ObservedCleanRunResult (RetainedGameResult × SplitHashCache)) × Digest => + ObservedCleanRunOption.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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..b0b795fe --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEager.lean @@ -0,0 +1,572 @@ +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, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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⟩, _hdoomed, + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + table ordinal target lazy.2 lazy.1 → + ObservedCleanRunOption.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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..ab1c2daa --- /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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] + 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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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..449c22d1 --- /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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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..5d3e0ae7 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedRootLazyEagerSuffix.lean @@ -0,0 +1,899 @@ +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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + table ordinal target rightRoot (some left)) : + ObservedCleanRunOption.SuccessfulDoomedFirstRootGoodForComparisonAt + table ordinal target rightRoot (some right) := by + rcases hrel with ⟨_hvalue, _htable, _hremaining, hobservations, hstate⟩ + rcases hgood with ⟨⟨⟨hfinish, hdoomed, 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⟩ + have hrightDoomed : + ¬DeferredCompletable table (directDeferredContext right.state) := by + intro hrightCompletable + exact hdoomed (deferredCompletable_direct_of_probeStateLE table + (hstate.toProbeStateLE hroot) hrightCompletable) + 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, hrightDoomed, 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + table ordinal target rightRoot lazy → + ObservedCleanRunOption.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + table ordinal target rightRoot lazy → + ObservedCleanRunOption.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt, + ObservedCleanRunOption.SuccessfulDoomedFirstRootHitAtTarget, + ObservedCleanRunOption.SuccessfulDoomedFirstExistingHiddenRootHitAt] 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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.SuccessfulDoomedFirstRootGoodForComparisonAt + 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..3d5a968a --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedSample.lean @@ -0,0 +1,244 @@ +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 : ∀ root, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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 : ∀ root, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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..7745f041 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedTop.lean @@ -0,0 +1,218 @@ +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, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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 : ∀ root, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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 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..cfa01498 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalClassificationStoppedTopKernel.lean @@ -0,0 +1,101 @@ +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, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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..ffa7a338 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalLift.lean @@ -0,0 +1,1153 @@ +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 : computation.IsQueryBoundP IsOuterHash 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 [OracleComp.isQueryBoundP_query_bind_iff] at hbound + rw [directDetailedBoundaryNormalizedPrivateWitnessSnapshotObserve, + OracleComp.construct_query_bind, observedMaterializedBoundary, + OracleComp.construct_query_bind] + cases query with + | inl worldQuery => + cases worldQuery with + | inl n => + 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 => + 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 houter).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 => + 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] + simpa [leftObserve, IsOuterHash] using + (ih nextLeft.value.1 snapshots observations canonical nextRight.context + nextLeft.remaining nextRight.remaining nextLeft.value.2 nextRight.value.2 bound + (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) + 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..a8924383 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalProbability.lean @@ -0,0 +1,1699 @@ +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⟩] + +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 : computation.IsQueryBoundP IsOuterHash 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 => + rw [OracleComp.isQueryBoundP_query_bind_iff] at hbound + 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_safeGuardedContinuation + parameter root ftsSecret next (splitUniformImpl n) state fuel cache 0 bound + hpublished hinnerBound (preservesPublishedValuesImpl_splitUniformImpl n) + (by omega) + have hdist : + 𝒟[sampledMaterializedCleanBoundaryFailure parameter root ftsSecret + ((liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (.inl (.inl n)))) >>= next) state fuel cache] = + 𝒟[runDirectDetailedSafeOrdinaryWithCompletionTable + (guardedMaterializedCleanContinuation parameter root ftsSecret next bound) + (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 + (guardedMaterializedCleanContinuation parameter root ftsSecret next bound) + (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 + · simp only [guardedMaterializedCleanContinuation, hguard] + exact ih value.1 nextContext.state remaining bound value.2 + (by simpa [IsOuterHash] using hbound.2 value.1) hguard.2 hguard.1 + · simp [guardedMaterializedCleanContinuation, hguard] + | 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 + rcases hbound.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_safeGuardedContinuation + parameter root ftsSecret next inner state fuel cache 1 nextBound hpublished + hinnerBound + (preservesPublishedValues_probingHashQueryAfterRootAwarePublicPlan parameter input + publicState plan) + (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 + (guardedMaterializedCleanContinuation parameter root ftsSecret next nextBound) + (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 + (guardedMaterializedCleanContinuation parameter root ftsSecret next nextBound) + (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 + · simp only [guardedMaterializedCleanContinuation, hguard] + exact ih value.1 nextContext.state remaining nextBound value.2 + (by + dsimp only [nextBound] + simpa [IsOuterHash] using hbound.2 value.1) + hguard.2 hguard.1 + · simp [guardedMaterializedCleanContinuation, hguard] + | inr message => + have hinnerBound : ((maskedSign parameter root ftsSecret message).run cache).IsQueryBoundP + LazyRevealProbe.IsProbe 0 := + maskedSign_probeFree parameter root ftsSecret message cache + have hstep := evalDist_sampledCleanStep_eq_safeGuardedContinuation + parameter root ftsSecret next (maskedSign parameter root ftsSecret message) + state fuel cache 0 bound hpublished hinnerBound + (preservesPublishedValues_maskedSign parameter root ftsSecret message) (by omega) + have hdist : + 𝒟[sampledMaterializedCleanBoundaryFailure parameter root ftsSecret + ((liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) + (.inr message))) >>= next) state fuel cache] = + 𝒟[runDirectDetailedSafeOrdinaryWithCompletionTable + (guardedMaterializedCleanContinuation parameter root ftsSecret next bound) + (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 + (guardedMaterializedCleanContinuation parameter root ftsSecret next bound) + (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 + · simp only [guardedMaterializedCleanContinuation, hguard] + exact ih value.1 nextContext.state remaining bound value.2 + (by simpa [IsOuterHash] using hbound.2 value.1) hguard.2 hguard.1 + · simp [guardedMaterializedCleanContinuation, hguard] + +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 : ∀ root, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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 (hbound 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 : ∀ root, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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..a99643d9 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSample.lean @@ -0,0 +1,193 @@ +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, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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 : ∀ root, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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 + +theorem probEvent_sampledGranularAllCanonical_root_le_materializedFailure_add_delayed + (adversary : Adversary) (parameter : PublicParameter) + (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (q : Nat) + (hbound : ∀ root, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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..248b025e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalSampleBase.lean @@ -0,0 +1,122 @@ +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, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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 : ∀ root, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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) + 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/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/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTop.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTop.lean new file mode 100644 index 00000000..b96564e2 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTop.lean @@ -0,0 +1,95 @@ +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, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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..fd3e0ef8 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopKernel.lean @@ -0,0 +1,79 @@ +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, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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..b21cb675 --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedBoundaryPrivateWitnessOrdinalRootGlobalTopStep.lean @@ -0,0 +1,131 @@ +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, + (retainedGameRestComputation adversary ⟨root, parameter⟩).IsQueryBoundP + IsOuterHash 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/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/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/OtsProbeResolvedDirectRecursive.lean b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedDirectRecursive.lean new file mode 100644 index 00000000..9b58f35f --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedDirectRecursive.lean @@ -0,0 +1,1909 @@ +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_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/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..4ce00c4e --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Proof/OtsProbeResolvedPrivateObserver.lean @@ -0,0 +1,2473 @@ +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) + +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 + +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/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/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/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/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/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/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/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/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/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/Statement.lean b/formal/sphincs/SphincsSecurity/Statement.lean new file mode 100644 index 00000000..123bc5ed --- /dev/null +++ b/formal/sphincs/SphincsSecurity/Statement.lean @@ -0,0 +1,876 @@ +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 claim `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 claim is `120` bits and not `128`. Every strategy the specification accounts for costs `2^-128` per query, and the bound is a slope `q / 2^120`, so `2^8` of slack absorbs the union bounds and the constants a proof accumulates, uniformly in `q`. The few-time leak is at most `2^-122` at `q_s = 2^24` (the exact count is about `2^-122.9`), so it does not bind once the mandatory signing work is included, but it is what fixes `signatureLimit`: it reaches `2^-128` at `2^25.1` signatures and `2^-120` at `2^26.4`, leaving about two doublings of headroom. `HasHashQueryBound` bounds every execution path, so `digestAttemptLimit` and `encodingAttemptLimit` put the admissible floor near `q = 2^58` even though a signature costs `2^20.5` on average, and the claim is read there. +-/ + +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 claimed security level. -/ +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 + +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