diff --git a/AGENTS.md b/AGENTS.md
index 9a2c5ada7..03d0f4391 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`. `formal/sphincs/` proves 127 bits of classical strong unforgeability in the random-oracle model for the SPHINCS instance, `sphincs_has_127_bits_of_classical_security`; `formal/sphincs/PROOF.md` explains the route, the module layout by component, and what to re-prove if the one-time signature changes. In both, `*/Statement.lean` defines 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`. Both root modules pin the axiom footprint of their theorem with `#guard_msgs`.
 - 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 4f825a410..a779789db 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}}
@@ -69,12 +70,12 @@
 
 \begin{itemize}
   \item \textbf{stateless}: supporting up to $2^{24}$ signatures.
-  \item \textbf{NIST security level~1}~\cite{NISTPQC} (TODO prove it)
+  \item \textbf{NIST security level~1}~\cite{NISTPQC}: 127 bits of classical strong unforgeability in the random-oracle model, proven in Lean (Section~\ref{sec:security}); the quantum analysis is still to do.
   \item \textbf{public key: 32 bytes}.
   \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}
 
@@ -365,7 +366,7 @@ \section{Signing}
 returning $\bot$ if $\OtsSign$ does.
 \item Output $\sigma=\left(\rho,(s_\kappa,B_\kappa)_{\kappa<k-1},(c_\lay,\sigma_\lay,A_\lay)_{\lay<d}\right)$.
 \end{enumerate}
-$M_{-1}$ is computed and discarded: it is $\rootnode$ whenever the signer is honest. The signature is serialized as
+$M_{-1}$ would be $\rootnode$ whenever the signer is honest, so the loop need not compute it. The signature is serialized as
 \[
   \rho
   \concat s_0\concat B_{0,0}\concat\cdots\concat B_{0,a-1}
@@ -427,7 +428,7 @@ \section{Costs}
 \end{center}
 
 \begin{remark}[Test vectors]
-Nothing implements this scheme yet, so the document carries no test vectors. One key pair, one message, and the resulting $\rho$, $\idx$, the $k$ indices $u_\kappa$, the $d$ counters $c_\lay$ and the 4924 signature bytes would pin every convention above, and should be added before anyone implements against it.
+The document carries no test vectors yet. One key pair, one message, and the resulting $\rho$, $\idx$, the $k$ indices $u_\kappa$, the $d$ counters $c_\lay$ and the 4924 signature bytes would pin every convention above, and should be added before anyone implements against it.
 \end{remark}
 
 \section{Security}
@@ -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}, and \texttt{sphincs\_has\_127\_bits\_of\_classical\_security} proves $x=127$ at $\qs=2^{24}$: the one bit below $n$ is what the proof spends on union bounds and constants. The proof is in the classical random-oracle model with independently sampled secrets; the seed derivation of Remark~\ref{rem:seed} and the instantiation of $\hash$ by BLAKE2s are outside it.
 
 \subsection{Quantum security}
 \label{sec:quantum}
diff --git a/formal/sphincs/.gitignore b/formal/sphincs/.gitignore
new file mode 100644
index 000000000..540493e25
--- /dev/null
+++ b/formal/sphincs/.gitignore
@@ -0,0 +1,3 @@
+/.lake/
+reach.txt
+taint.txt
diff --git a/formal/sphincs/PROOF.md b/formal/sphincs/PROOF.md
new file mode 100644
index 000000000..7d86bef35
--- /dev/null
+++ b/formal/sphincs/PROOF.md
@@ -0,0 +1,89 @@
+# The 127-bit proof
+
+`sphincs_has_127_bits_of_classical_security` in [SphincsSecurity.lean](SphincsSecurity.lean) proves `HasClassicalSecurityBits scheme 127` for the concrete SPHINCS instance of [Statement.lean](SphincsSecurity/Statement.lean): every adversary whose whole experiment, key generation and signing included, makes at most $q\ge1$ random-oracle queries produces a strong forgery with probability at most $q/2^{127}$. The proof uses only `propext`, `Classical.choice` and `Quot.sound`, which the root module pins with `#guard_msgs` on every build.
+
+Throughout, $N=2^{128}$, $x=q/N$, $\delta=11/65536$ and $r_{\rm cache}=1023/2^{186}+2^{-170}$. The proof splits the budget at $q_0=3\cdot2^{114}$: budgets at least $q_0$ are closed by the retained residual monitor, smaller positive budgets by the forced few-time-signature (FTS) games.
+
+## Layout
+
+| Directory | Role | What the rest of the proof uses from it |
+| --- | --- | --- |
+| [Statement.lean](SphincsSecurity/Statement.lean) | Parameters, byte layouts, the three algorithms, the SUF game, the claims. | Everything; nothing here is a proof step. |
+| [Proof/Base](SphincsSecurity/Proof/Base) | Scheme-independent tooling: uniform tables with restricted row supports and their exact adaptive posteriors, query caps, pauses and traces, random-oracle query charges, weighted executions, moment bounds. | Generic lemmas. |
+| [Proof/Scheme](SphincsSecurity/Proof/Scheme) | The concrete game over a query cache, honest computation, extraction of witnesses from an accepting signature, cost bookkeeping. | The cached game and the witness extractors. |
+| [Proof/Hypertree](SphincsSecurity/Proof/Hypertree) | The canonical graph of every honest hash input, frontier oracles, structural (noncanonical output) matches, layer and hypertree witnesses. | `StructuralMatchBound` and the hypertree witness. |
+| [Proof/Chains](SphincsSecurity/Proof/Chains) | Abstract chain tables, independent of the scheme: adaptive likelihoods of prefix queries, first contact, restarts, two-edge completions and their moments. | Generic lemmas about chain tables. |
+| [Proof/Ots](SphincsSecurity/Proof/Ots) | The one-time signature: prefix simulation and allocation, contacts, distinct contacts, encoding neighbors, markers and matches on the concrete chains, the OTS verifier witness. | The primitive events and their probability bounds. |
+| [Proof/Fts](SphincsSecurity/Proof/Fts) | The few-time signature and the message digest: target certificates, the banked certificate monitor, proposal words, the terminal certificate price, digest cache exceptions. | Certificate bounds, the exception bounds and the terminal price. |
+| [Proof/Reference](SphincsSecurity/Proof/Reference) | The reference experiment that ties the components: sampled reference family, forgery source, verifier classification, primitive-event union, query allocation, certificate coverage. | `forgeAdvantage_le_remainingFts_small_budget`. |
+| [Proof/Residual](SphincsSecurity/Proof/Residual) | The retained residual monitor on the original game and the large-budget theorem. | `security127_of_large_budget`. |
+| [Proof/Forced](SphincsSecurity/Proof/Forced) | The continuing secret-guess interpreter, the forced FTS games, their monitored runs and the small-budget arithmetic. | `forcedNearGame_le` and `small_bound_le_security127`. |
+| [Proof/Security127Completion.lean](SphincsSecurity/Proof/Security127Completion.lean) | Combines both budget ranges into `security127`. | The public theorem. |
+
+## Large budgets
+
+`forgeAdvantage_le_native_bound` in [Residual/RetainedResidualCacheTail.lean](SphincsSecurity/Proof/Residual/RetainedResidualCacheTail.lean) bounds the original SUF probability by $2x-x^2+\delta x+q\,r_{\rm cache}+2^{-700}$ for $q\le2^{127}$. Original success is a primitive stop or a live strong forgery; a live strong forgery yields a full target certificate in the retained cache and signing log; a passive certificate monitor counts every such certificate in its bank unless it stopped on a cache exception or a proposal-prefix exception; the expected bank count is paid by the native message work and the terminal certificate price; the two exceptions have probabilities at most $q\,r_{\rm cache}$ and $2^{-700}$. `security127_of_large_budget` in [Residual/Security127LargeBudget.lean](SphincsSecurity/Proof/Residual/Security127LargeBudget.lean) closes $q\ge q_0$ by exact arithmetic, and budgets at least $2^{127}$ by probability at most one.
+
+## Small budgets
+
+`forgeAdvantage_le_remainingFts_small_budget` in [Reference/ReferenceCertificateCoverage.lean](SphincsSecurity/Proof/Reference/ReferenceCertificateCoverage.lean) bounds the original SUF probability for $q\le q_0$ by $(7/4+\delta)x+2^{-700}$ plus the probability, on the retained reference forgery source, of a near certificate with an undisclosed true FTS secret query or of two distinct undisclosed true FTS secret queries. The $(7/4)x$ term is the union of the primitive events on the reference law: an equal-encoding match, a structural match, a two-edge OTS completion, two distinct OTS contacts, or a marked and contacted chain, each charged to the shared query allocation $Q_{\rm prefix}+A_{\rm enc}+A_{\rm other}+A_{\rm msg}\le q$. The full-certificate alternative is the large-budget certificate bound transported through the original cache.
+
+`forgeAdvantage_le_forcedNear_small_budget` in [Forced/FtsGuessNearSource.lean](SphincsSecurity/Proof/Forced/FtsGuessNearSource.lean) replaces the two FTS alternatives. Two distinct guesses cost at most $x^2/[2(1-x)^2]$ through a potential on the continuing guess interpreter. The near-certificate alternative is at most $(N-q)^{-1}\sum_{j<q}\Pr[F_j]$, where $F_j$ is the near-certificate event in the forced game that makes the $j$th eligible secret test hit.
+
+`forcedNearGame_le` in [Forced/FtsGuessNearAssembly.lean](SphincsSecurity/Proof/Forced/FtsGuessNearAssembly.lean) proves $\Pr[F_j]\le557x+14(q\,r_{\rm cache}+2^{-700})$ for $q\le2^{127}$. The forced run is monitored by the same certificate monitor as the large-budget route, with public key fields and the key-generation debit, and erasing the monitor recovers the forced run exactly. On an unstopped monitor a near certificate is banked, so its probability is at most the expected creation cost, which the proposal-word martingale bounds by $q$ times the terminal certificate price. A stopped monitor is a cache exception or a prefix exception. The price averages, over the fixed-length proposal word, to the thirteenth binomial moment of the per-index counts; summing the fourteen omitted trees gives the bound.
+
+`small_bound_le_security127` in [Forced/Security127SmallBudgetArithmetic.lean](SphincsSecurity/Proof/Forced/Security127SmallBudgetArithmetic.lean) checks that $(7/4+\delta)x+2^{-700}+x^2/[2(1-x)^2]+x(557x+14q/2^{169}+14\cdot2^{-700})/(1-x)\le2x$ for $1\le q\le q_0$; the left side is about $1.85x$ at $q=q_0$, so the closing arithmetic has slack of about $0.15x$ there.
+
+## Component dependencies
+
+[scripts/Taint.lean](scripts/Taint.lean) is the second audit script: `lake env lean scripts/Taint.lean` writes `taint.txt`, which records for every declaration whether it references the one-time-signature definitions of `Statement.lean` (`chainWalk`, `encode`, `otsSign`, `decodeDigest` and their relatives), the few-time-signature definitions or the hypertree definitions, directly or through the declarations it uses. The table below summarizes it per directory. A module in the *no component* column mentions none of the three, directly or indirectly, so it is generic tooling. A module in the *OTS transitively* column depends on the one-time signature only through the scheme's algorithms, so it survives a change of the one-time signature that keeps the two interfaces above. A module in the *OTS directly* column mentions the one-time-signature definitions itself and must be re-read.
+
+| Directory | Modules | No component | Components without OTS | OTS transitively | OTS directly |
+| --- | --- | --- | --- | --- | --- |
+| [Base](SphincsSecurity/Proof/Base) | 33 | 33 | 0 | 0 | 0 |
+| [Chains](SphincsSecurity/Proof/Chains) | 39 | 39 | 0 | 0 | 0 |
+| [Scheme](SphincsSecurity/Proof/Scheme) | 20 | 7 | 1 | 5 | 7 |
+| [Hypertree](SphincsSecurity/Proof/Hypertree) | 41 | 4 | 0 | 15 | 22 |
+| [Ots](SphincsSecurity/Proof/Ots) | 125 | 3 | 0 | 19 | 103 |
+| [Fts](SphincsSecurity/Proof/Fts) | 172 | 23 | 26 | 118 | 5 |
+| [Reference](SphincsSecurity/Proof/Reference) | 38 | 4 | 0 | 18 | 16 |
+| [Residual](SphincsSecurity/Proof/Residual) | 99 | 5 | 1 | 68 | 25 |
+| [Forced](SphincsSecurity/Proof/Forced) | 50 | 12 | 0 | 30 | 8 |
+| [Security127Completion.lean](SphincsSecurity/Proof/Security127Completion.lean) | 1 | 0 | 0 | 1 | 0 |
+
+The modules outside [Ots](SphincsSecurity/Proof/Ots) that mention the one-time-signature definitions directly are the scheme basics that extract a signature's chain values, the canonical graph and frontier oracles that enumerate every honest hash input, the reference experiment's causal program, and the places where the residual monitor and the forced games replay a verified signature: `BoundaryHashEvaluation`, `Bytes`, `CanonicalCoordinateSampling`, `CanonicalGraphHonest`, `CanonicalGraphSampling`, `CanonicalGraph`, `CanonicalHiddenCoordinates`, `CanonicalProbeCache`, `CanonicalProbeRouting`, `CanonicalSigningFrontier`, `CausalFrontierProgram`, `Code`, `Descent`, `ForgeryClassify`, `FrontierEncodingCongruence`, `FrontierOracleCongruence`, `FrontierOracleMask`, `FrontierSignerErasure`, `FrontierSigningEvaluation`, `FrontierTreeEvaluation`, `FtsGuessBudget`, `FtsGuessCachedForced`, `FtsGuessDeferredMessage`, `FtsGuessHash`, `FtsGuessNearAssembly`, `FtsGuessNearDeferred`, `FtsGuessNearSource`, `FtsGuessRemaining`, `FtsVerifierWitness`, `GraphPayloadInputs`, `Honest`, `InterleavedResidualDisclosure`, `MessageByteTrace`, `NoMessage`, `Position`, `PublicGraphOpenings`, `PublicGraphSigner`, `PublicReferenceResidual`, `PublicResidualLookup`, `Queried`, `QueryClassAllocation`, `ReferenceAuxiliarySigning`, `ReferenceCertificateCoverage`, `ReferenceContactGame`, `ReferenceForgerySource`, `ReferenceHypertreeWitness`, `ReferenceJointPrior`, `ReferenceOracleConditioning`, `ReferencePrimitiveWitness`, `ReferenceQueryAllocation`, `ReferenceResidualSampling`, `ReferenceResidualSeeds`, `ReferenceSigningReplay`, `ReferenceVerifierInstantiation`, `ResidualByteCandidates`, `ResidualByteCheckedHazard`, `RetainedResidualCacheTail`, `RetainedResidualCertificateTransfer`, `RetainedResidualCheckedTrace`, `RetainedResidualEncodingHistory`, `RetainedResidualEnvelope`, `RetainedResidualExceptionGame`, `RetainedResidualHashTrace`, `RetainedResidualHazard`, `RetainedResidualMessageKernel`, `RetainedResidualMonitoredGame`, `RetainedResidualOriginalBudget`, `RetainedResidualPrimitivePotential`, `RetainedResidualProposalTail`, `RetainedResidualQueryPotential`, `RetainedResidualRecovery`, `RetainedResidualReplay`, `RetainedResidualSource`, `RetainedResidualStrongCoverage`, `RetainedResidualTraceValidity`, `RetainedResidualVerifySupport`, `RetainedResidualVerify`, `RootCache`, `StatementLemmas`, `StructuralMatchKernel`, `StructuralOracleSplit`, `Support`, `VerifierWitnessClassification`.
+
+## Why the proof has this shape
+
+Write $x=q/2^{128}$. Every fresh oracle query in the experiment carries at most two unit hazards. A query at a hidden coordinate with a candidate value either equals the secret, with probability about $1/2^{128}$ over the remaining candidates, or its fresh output equals the known next chain value, with probability $1/2^{128}$; either outcome gives the adversary a lower digit. The crude route, everything under [Residual](SphincsSecurity/Proof/Residual), charges every query these two hazards through the potential $1-(1-1/2^{128})^2$ per query and pays the certificate bank out of the same potential, which is why it stops at $2x-x^2$ and then has only $x^2$ left to absorb the certificate excess $\delta x$, the rate at which some index collects eleven or more signatures. Below $q\approx2^{115}$ that excess is larger than $x^2$, and no accounting of the crude kind can help, because any additive term must fit under $x^2$.
+
+The refined route recovers the last bit by showing that a single contact is not a forgery. A one-time forgery needs a two-edge completion, two distinct contacts, or a contact together with an encoding marker, and the first of these is the only first-order event, at $(3/2+4x+2x^2)/(1-x)$ per prefix query. That analysis is [Chains](SphincsSecurity/Proof/Chains) and most of [Ots](SphincsSecurity/Proof/Ots); the forced games of [Forced](SphincsSecurity/Proof/Forced) do the same for the few-time secret guess. Its second-order terms, $557x^2/(1-x)$ for a near certificate followed by a guess and $x^2/[2(1-x)^2]$ for two guesses, grow past the budget above $q\approx3\cdot2^{114}$, so the refined route cannot replace the crude one either. With the target $2x$ and this proof strategy, both routes are needed.
+
+Measured on the current tree, the crude route alone reaches 372 modules and 39k lines and proves 126 bits for every budget. The refined route adds 246 modules and 27k lines: 96 in `Ots`, 50 in `Forced`, 39 in `Chains`, and the rest spread over `Reference`, `Base`, `Hypertree` and `Fts`. The last bit costs about forty percent of the proof.
+
+## What would simplify it
+
+- **Accept 126 bits.** Delete the refined route and close every budget with `forgeAdvantage_le_native_bound`, whose bound $2x-x^2+\delta x+q/2^{169}+2^{-700}$ is below $4x$ for every $q\ge1$. This removes 246 modules with no new proof work.
+- **Precompute the key, as `formal/xmss` does.** There, key generation computes every chain value and Merkle node through the oracle once and signing only reads tables and hashes the message and the encodings. The SPHINCS statement instead lets the signer recompute through the oracle, and the price of that faithfulness is the whole native accounting layer: spent counters, cache growth and its second-moment exceptions, message charges, macro budgets and proposal-prefix stops, most of `Residual` and a third of `Fts`. A precomputed key moves the honest hash cost to key generation, which only changes where the slope bound becomes vacuous, and would let the one-time and hypertree parts follow the XMSS proof, which already reaches 127 bits for those components.
+- **State the scheme over an abstract one-time signature.** The rest of the proof uses the OTS through two results, the layer witness and the primitive-event bound with its constant $7/4$. Making the OTS a structure in `Statement.lean` with those two results as its interface, and proving them for the target-sum instance in `Ots`, is what would make the OTS replaceable; today the boundary is a directory and a table in this guide.
+
+The first item is a decision about the claim, and the requirement to keep 127 bits excludes it. The other two are a redesign of the statement followed by a rewrite of the crude route, not a cleanup, and they are where the remaining complexity actually lives; neither has been started. What has been done on the existing proof is the mechanical part: dead code pruned by proof-term reachability, subsumed imports and single-importer modules folded away, and both routes now share one proposal model, the uniform word of length `fixedProposalLength`.
+
+## Changing the one-time signature
+
+Everything specific to the Winternitz-style target-sum OTS lives in [Statement.lean](SphincsSecurity/Statement.lean) (`numChains`, `chainLength`, `targetSum`, `decodeDigest`, `chainWalk`, `encode` and `otsSign`) and in [Proof/Ots](SphincsSecurity/Proof/Ots); [Proof/Chains](SphincsSecurity/Proof/Chains) reasons about abstract chain tables and does not mention them, so it survives any chain-based replacement. The rest of the proof consumes the OTS through two results only.
+
+- **The primitive-event bound.** `referenceGraphContextGame_primitive_small_budget` in [Reference/ReferencePrimitiveBound.lean](SphincsSecurity/Proof/Reference/ReferencePrimitiveBound.lean): on the reference law, the union of the OTS events with the equal-encoding and structural matches plus $(7/4)\mathbb E_R A_{\rm msg}/N$ is at most $(7/4)x$ for $q\le q_0$. The OTS-specific inputs are the per-event estimates in [Ots](SphincsSecurity/Proof/Ots) (two-edge $(3/2+4x+2x^2)\mathbb E Q/N$, distinct contacts $4x\mathbb E Q/[(1-x)^2N]$, marker and contact $(82x\mathbb E Q+3444x\mathbb E A_{\rm enc})/[(1-x)N]$, equal encoding $\mathbb E A_{\rm enc}/N$) and the neighbor counts 41 and 1722 of [Ots/EncodingNeighbors.lean](SphincsSecurity/Proof/Ots/EncodingNeighbors.lean). A new OTS needs new versions of these estimates; the closing arithmetic absorbs a total primitive coefficient of up to about $1.88$ in place of $7/4$.
+- **The layer witness.** `layer_reference_classification` in [Ots/ReferenceLayerWitness.lean](SphincsSecurity/Proof/Ots/ReferenceLayerWitness.lean) with `otsLeaf_classification` in [Ots/OtsVerifierWitness.lean](SphincsSecurity/Proof/Ots/OtsVerifierWitness.lean): an accepting layer whose recovered root is canonical either fixes the reference opening or exhibits one of the primitive events on the actual verifier trace. `verify_classification` in [Reference/VerifierWitnessClassification.lean](SphincsSecurity/Proof/Reference/VerifierWitnessClassification.lean) composes it through the hypertree and the FTS layer.
+
+For a change that keeps the chain structure and alters the parameters (`winternitzBits`, `numChains`, `targetSum`, the encoding), the places that hard-code their consequences are:
+
+- the neighbor counts 41 and 1722 of the target-sum code: [Ots/EncodingNeighbors.lean](SphincsSecurity/Proof/Ots/EncodingNeighbors.lean), [Ots/EncodingFreshRow.lean](SphincsSecurity/Proof/Ots/EncodingFreshRow.lean), [Ots/EncodingMarkerKernel.lean](SphincsSecurity/Proof/Ots/EncodingMarkerKernel.lean) and the marker accumulation modules that carry them;
+- the derived rates 82 and 3444 in [Ots/OtsContactMarkerBound.lean](SphincsSecurity/Proof/Ots/OtsContactMarkerBound.lean), [Ots/OtsMarkerContactBound.lean](SphincsSecurity/Proof/Ots/OtsMarkerContactBound.lean) and [Ots/OtsMarkerContactProbability.lean](SphincsSecurity/Proof/Ots/OtsMarkerContactProbability.lean);
+- the chain-length dependence of the two-edge rate $3/2+4x+2x^2$ in [Chains/AdaptiveChainTwoEdge.lean](SphincsSecurity/Proof/Chains/AdaptiveChainTwoEdge.lean) and [Ots/OtsPrefixTwoEdgeProbability.lean](SphincsSecurity/Proof/Ots/OtsPrefixTwoEdgeProbability.lean);
+- the total primitive coefficient $7/4$ in [Reference/ReferencePrimitiveBound.lean](SphincsSecurity/Proof/Reference/ReferencePrimitiveBound.lean), consumed by [Reference/ReferenceCertificateCoverage.lean](SphincsSecurity/Proof/Reference/ReferenceCertificateCoverage.lean), [Forced/FtsGuessRemaining.lean](SphincsSecurity/Proof/Forced/FtsGuessRemaining.lean), [Forced/FtsGuessNearSource.lean](SphincsSecurity/Proof/Forced/FtsGuessNearSource.lean) and the closing arithmetic in [Forced/Security127SmallBudgetArithmetic.lean](SphincsSecurity/Proof/Forced/Security127SmallBudgetArithmetic.lean);
+- the byte layout and extraction facts that mention `numChains`, `chainLength` or `winternitzBits`: [Scheme/Bytes.lean](SphincsSecurity/Proof/Scheme/Bytes.lean), [Scheme/Code.lean](SphincsSecurity/Proof/Scheme/Code.lean), [Hypertree/Position.lean](SphincsSecurity/Proof/Hypertree/Position.lean), [Ots/OneTime.lean](SphincsSecurity/Proof/Ots/OneTime.lean), [Ots/ExtractOts.lean](SphincsSecurity/Proof/Ots/ExtractOts.lean) and the frontier evaluation modules under [Hypertree](SphincsSecurity/Proof/Hypertree).
+
+Everything else takes these constants through the lemmas above. The few-time constants (557 and the fourteen trees) are independent of the one-time signature.
+
+The FTS, message-digest, residual-monitor and forced-game components depend on the OTS only through these two interfaces and through the whole-experiment hash budget, so a different OTS leaves [Proof/Fts](SphincsSecurity/Proof/Fts), [Proof/Residual](SphincsSecurity/Proof/Residual) and [Proof/Forced](SphincsSecurity/Proof/Forced) unchanged. The boundary is at the level of lemma statements and directories, not of an abstract Lean interface: the OTS constants are definitions in `Statement.lean`, and the [Ots](SphincsSecurity/Proof/Ots) proofs use their concrete values.
diff --git a/formal/sphincs/README.md b/formal/sphincs/README.md
new file mode 100644
index 000000000..69dbc1c78
--- /dev/null
+++ b/formal/sphincs/README.md
@@ -0,0 +1,37 @@
+# SPHINCS security in Lean 4
+
+The public theorem proves **127 bits of classical strong unforgeability in the random-oracle model** for the concrete SPHINCS instance of `doc/sphincs`, with at most `2^24` signing requests per key pair: every adversary whose whole experiment makes at most $q\ge1$ hash queries forges with probability at most $q/2^{127}$.
+
+[Statement.lean](SphincsSecurity/Statement.lean) defines the concrete parameters, serialized hash inputs, algorithms, the SUF game and the claim. The claim uses independently sampled secret leaves and a random oracle; instantiating that oracle with BLAKE2s or deriving all secrets from a seed is outside this theorem. The whole-experiment query budget includes key generation, signing failures, repeated calls and final verification.
+
+## Build and audit
+
+Use the pinned Lean toolchain and VCVio revision:
+
+```sh
+cd formal/sphincs
+lake exe cache get
+lake build
+```
+
+The cache command is needed on initial setup. The root module pins the axiom footprint of the theorem to `propext`, `Classical.choice` and `Quot.sound` with `#guard_msgs`, so the build fails if it ever grows. [scripts/Reach.lean](scripts/Reach.lean) is a maintenance script: `lake env lean scripts/Reach.lean` writes `reach.txt`, listing every local declaration with the line range of its source block and whether the proof terms of the public theorem reach it, which is how dead code is found before pruning.
+
+## Where to work
+
+[PROOF.md](PROOF.md) explains the route, the constants, the component dependencies of every directory and which modules must change if the one-time signature changes. The proof is split by component:
+
+| Entry | Purpose |
+| --- | --- |
+| [SphincsSecurity.lean](SphincsSecurity.lean) | The public theorem. |
+| [Proof/Security127Completion.lean](SphincsSecurity/Proof/Security127Completion.lean) | Combines the large-budget and small-budget bounds into `security127`. |
+| [Proof/Base](SphincsSecurity/Proof/Base) | Scheme-independent tooling: uniform tables and their exact adaptive posteriors, query caps, pauses and traces, oracle query charges, moment bounds. |
+| [Proof/Scheme](SphincsSecurity/Proof/Scheme) | The concrete game over a query cache, honest computation and witness extraction from an accepting signature. |
+| [Proof/Hypertree](SphincsSecurity/Proof/Hypertree) | The canonical graph of honest hash inputs, frontier oracles, structural matches, layer and hypertree witnesses. |
+| [Proof/Chains](SphincsSecurity/Proof/Chains) | Abstract chain tables and their adaptive query bounds, independent of the scheme. |
+| [Proof/Ots](SphincsSecurity/Proof/Ots) | The one-time signature: prefix simulation, contacts, encoding neighbors, markers and matches on the concrete chains, the OTS verifier witness. |
+| [Proof/Fts](SphincsSecurity/Proof/Fts) | The few-time signature and message digest: target certificates, the banked monitor, proposal words, the terminal certificate price, cache exceptions. |
+| [Proof/Reference](SphincsSecurity/Proof/Reference) | The reference experiment: sampled reference family, forgery source, verifier classification, primitive-event union, query allocation, certificate coverage. |
+| [Proof/Residual](SphincsSecurity/Proof/Residual) | The retained residual monitor on the original game and the large-budget theorem. |
+| [Proof/Forced](SphincsSecurity/Proof/Forced) | The secret-guess interpreter, the forced FTS games, their monitored runs and the small-budget arithmetic. |
+
+Superseded proof routes and their planning notes are in the Git history.
diff --git a/formal/sphincs/SphincsSecurity.lean b/formal/sphincs/SphincsSecurity.lean
new file mode 100644
index 000000000..299e6abbe
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity.lean
@@ -0,0 +1,20 @@
+import SphincsSecurity.Statement
+import SphincsSecurity.Proof
+
+namespace SphincsSecurity
+
+/-!
+The main result. Its statement lives entirely in the single module `SphincsSecurity.Statement`; the modules under `SphincsSecurity/Proof/` only contribute to the proof, which splits the whole-experiment hash budget at `3 * 2^114`: larger budgets are bounded by the retained residual certificate monitor, and smaller budgets reduce the remaining near-certificate event to forced FTS guess games that are bounded slot by slot.
+-/
+
+/-- `127` bits of classical strong unforgeability in the random-oracle model for the concrete SPHINCS instance, at `2^24` signing requests per key pair. -/
+theorem sphincs_has_127_bits_of_classical_security : SphincsSecurityStatement :=
+  Concrete.security127
+
+/-! The build fails if the axiom footprint ever grows beyond Lean's three standard axioms, so a `sorry` or `native_decide` anywhere in the proof cannot go unnoticed. -/
+
+/-- info: 'SphincsSecurity.sphincs_has_127_bits_of_classical_security' depends on axioms: [propext, Classical.choice, Quot.sound] -/
+#guard_msgs in
+#print axioms sphincs_has_127_bits_of_classical_security
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof.lean b/formal/sphincs/SphincsSecurity/Proof.lean
new file mode 100644
index 000000000..642dc7012
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof.lean
@@ -0,0 +1 @@
+import SphincsSecurity.Proof.Security127Completion
\ No newline at end of file
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/BernoulliExcessMoments.lean b/formal/sphincs/SphincsSecurity/Proof/Base/BernoulliExcessMoments.lean
new file mode 100644
index 000000000..f14aa258a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/BernoulliExcessMoments.lean
@@ -0,0 +1,31 @@
+import SphincsSecurity.Proof.Base.Prelude
+namespace SphincsSecurity
+
+theorem positivePart_shift_even_le (score shift : ℝ) (power : Nat) (heven : Even power) :
+    max (score + shift) 0 ^ power ≤ (max score 0 + shift) ^ power := by
+  by_cases hnonneg : 0 ≤ score + shift
+  · rw [max_eq_left hnonneg]
+    exact pow_le_pow_left₀ hnonneg (add_le_add (le_max_left score 0) le_rfl) power
+  · rw [max_eq_right (le_of_not_ge hnonneg)]
+    by_cases hpower : power = 0
+    · simp [hpower]
+    · rw [zero_pow hpower]
+      exact heven.pow_nonneg _
+
+theorem bernoulliExcess_secondMoment_le (score probability : ℝ)
+    (hprob : 0 ≤ probability) (hprob_one : probability ≤ 1) :
+    probability * max (score + (1 - probability)) 0 ^ 2 +
+        (1 - probability) * max (score + (-probability)) 0 ^ 2 ≤
+      max score 0 ^ 2 + probability := by
+  let d := max score 0
+  have hmiss : 0 ≤ 1 - probability := sub_nonneg.mpr hprob_one
+  calc
+    _ ≤ probability * (d + (1 - probability)) ^ 2 +
+        (1 - probability) * (d + (-probability)) ^ 2 :=
+      add_le_add
+        (mul_le_mul_of_nonneg_left (positivePart_shift_even_le score (1 - probability) 2 (by decide)) hprob)
+        (mul_le_mul_of_nonneg_left (positivePart_shift_even_le score (-probability) 2 (by decide)) hmiss)
+    _ = d ^ 2 + probability * (1 - probability) := by ring
+    _ ≤ _ := by dsimp only [d]; nlinarith [sq_nonneg probability]
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/BinomialMoments.lean b/formal/sphincs/SphincsSecurity/Proof/Base/BinomialMoments.lean
new file mode 100644
index 000000000..521c813eb
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/BinomialMoments.lean
@@ -0,0 +1,315 @@
+import SphincsSecurity.Proof.Base.Prelude
+namespace SphincsSecurity.Concrete
+
+open ENNReal
+
+noncomputable def binomialAverage (rate : ENNReal) : Nat → (Nat → ENNReal) → ENNReal
+  | 0, f => f 0
+  | steps + 1, f =>
+      (1 - rate) * binomialAverage rate steps f +
+        rate * binomialAverage rate steps (fun count => f (count + 1))
+
+theorem binomialAverage_zero (rate : ENNReal) (f : Nat → ENNReal) :
+    binomialAverage rate 0 f = f 0 := rfl
+
+theorem binomialAverage_succ (rate : ENNReal) (steps : Nat) (f : Nat → ENNReal) :
+    binomialAverage rate (steps + 1) f =
+      (1 - rate) * binomialAverage rate steps f +
+        rate * binomialAverage rate steps (fun count => f (count + 1)) := rfl
+
+theorem binomialAverage_add (rate : ENNReal) (steps : Nat) (f g : Nat → ENNReal) :
+    binomialAverage rate steps (fun count => f count + g count) =
+      binomialAverage rate steps f + binomialAverage rate steps g := by
+  induction steps generalizing f g with
+  | zero => rfl
+  | succ steps ih =>
+      simp only [binomialAverage_succ, ih, mul_add]
+      ac_rfl
+
+theorem binomialAverage_mul_left (rate factor : ENNReal) (steps : Nat) (f : Nat → ENNReal) :
+    binomialAverage rate steps (fun count => factor * f count) =
+      factor * binomialAverage rate steps f := by
+  induction steps generalizing f with
+  | zero => rfl
+  | succ steps ih =>
+      simp only [binomialAverage_succ, ih]
+      ring
+
+theorem binomialAverage_mul_right (rate factor : ENNReal) (steps : Nat) (f : Nat → ENNReal) :
+    binomialAverage rate steps (fun count => f count * factor) =
+      binomialAverage rate steps f * factor := by
+  simpa only [mul_comm] using binomialAverage_mul_left rate factor steps f
+
+theorem binomialAverage_sum {α : Type*} (rate : ENNReal) (steps : Nat) (set : Finset α)
+    (f : α → Nat → ENNReal) :
+    binomialAverage rate steps (fun count => ∑ i ∈ set, f i count) =
+      ∑ i ∈ set, binomialAverage rate steps (f i) := by
+  induction steps generalizing f with
+  | zero => rfl
+  | succ steps ih =>
+      simp only [binomialAverage_succ, ih, Finset.mul_sum, Finset.sum_add_distrib]
+
+theorem binomialAverage_mono (rate : ENNReal) (steps : Nat) {f g : Nat → ENNReal}
+    (h : ∀ count, f count ≤ g count) :
+    binomialAverage rate steps f ≤ binomialAverage rate steps g := by
+  induction steps generalizing f g with
+  | zero => exact h 0
+  | succ steps ih =>
+      exact add_le_add (mul_le_mul' le_rfl (ih h))
+        (mul_le_mul' le_rfl (ih (fun count => h (count + 1))))
+
+theorem bernoulli_mix_increment {rate : ENNReal} (hrate : rate ≤ 1) (value increment : ENNReal) :
+    (1 - rate) * value + rate * (value + increment) = value + rate * increment := by
+  calc
+    _ = (1 - rate + rate) * value + rate * increment := by ring
+    _ = _ := by rw [tsub_add_cancel_of_le hrate, one_mul]
+
+theorem binomialAverage_const {rate : ENNReal} (hrate : rate ≤ 1) (steps : Nat) (value : ENNReal) :
+    binomialAverage rate steps (fun _ => value) = value := by
+  induction steps with
+  | zero => rfl
+  | succ steps ih =>
+      rw [binomialAverage_succ, ih, ← add_mul, tsub_add_cancel_of_le hrate, one_mul]
+
+theorem binomialAverage_choose {rate : ENNReal} (hrate : rate ≤ 1) (steps degree : Nat) :
+    binomialAverage rate steps (fun count => (count.choose degree : ENNReal)) =
+      (steps.choose degree : ENNReal) * rate ^ degree := by
+  induction steps generalizing degree with
+  | zero =>
+      cases degree <;> simp [binomialAverage_zero]
+  | succ steps ih =>
+      cases degree with
+      | zero => simp only [Nat.choose_zero_right, Nat.cast_one, pow_zero, mul_one, binomialAverage_const hrate]
+      | succ degree =>
+          rw [binomialAverage_succ]
+          simp_rw [Nat.choose_succ_succ, Nat.cast_add]
+          rw [binomialAverage_add]
+          simp_rw [ih]
+          rw [add_comm ((steps.choose degree : ENNReal) * rate ^ degree), bernoulli_mix_increment hrate]
+          simp only [Nat.succ_eq_add_one, pow_succ]
+          ring
+
+theorem binomialAverage_descFactorial {rate : ENNReal} (hrate : rate ≤ 1) (steps degree : Nat) :
+    binomialAverage rate steps (fun count => (count.descFactorial degree : ENNReal)) =
+      (steps.descFactorial degree : ENNReal) * rate ^ degree := by
+  simp_rw [Nat.descFactorial_eq_factorial_mul_choose, Nat.cast_mul]
+  rw [binomialAverage_mul_left, binomialAverage_choose hrate]
+  ring
+
+theorem mul_descFactorial_eq (count degree : Nat) :
+    count * count.descFactorial degree =
+      count.descFactorial (degree + 1) + degree * count.descFactorial degree := by
+  by_cases h : degree ≤ count
+  · rw [Nat.descFactorial_succ, ← Nat.add_mul, Nat.sub_add_cancel h]
+  · rw [Nat.descFactorial_eq_zero_iff_lt.mpr (by omega), Nat.mul_zero,
+      Nat.descFactorial_eq_zero_iff_lt.mpr (by omega), Nat.mul_zero, Nat.add_zero]
+
+theorem power_eq_stirling_descFactorial (count degree : Nat) :
+    count ^ degree = ∑ order ∈ Finset.range (degree + 1),
+      Nat.stirlingSecond degree order * count.descFactorial order := by
+  induction degree with
+  | zero => simp
+  | succ degree ih =>
+      rw [pow_succ, ih, Finset.sum_mul,
+        Finset.sum_range_succ' (fun order => Nat.stirlingSecond (degree + 1) order * count.descFactorial order)]
+      simp only [Nat.stirlingSecond_succ_zero, Nat.zero_mul, Nat.add_zero,
+        Nat.stirlingSecond_succ_succ, Nat.add_mul, Finset.sum_add_distrib]
+      have hshift :
+          (∑ order ∈ Finset.range (degree + 1),
+            (order + 1) * Nat.stirlingSecond degree (order + 1) * count.descFactorial (order + 1)) =
+          ∑ order ∈ Finset.range (degree + 1),
+            order * Nat.stirlingSecond degree order * count.descFactorial order := by
+        let f := fun order => order * Nat.stirlingSecond degree order * count.descFactorial order
+        change (∑ order ∈ Finset.range (degree + 1), f (order + 1)) =
+          ∑ order ∈ Finset.range (degree + 1), f order
+        calc
+          _ = ∑ order ∈ Finset.range (degree + 2), f order := by
+            simpa [f] using (Finset.sum_range_succ' f (degree + 1)).symm
+          _ = _ := by
+            rw [Finset.sum_range_succ]
+            simp [f, Nat.stirlingSecond_eq_zero_of_lt (Nat.lt_succ_self degree)]
+      simp only [Nat.add_mul, Finset.sum_add_distrib] at hshift
+      rw [hshift, ← Finset.sum_add_distrib]
+      apply Finset.sum_congr rfl
+      intro order _
+      calc
+        _ = Nat.stirlingSecond degree order * (count * count.descFactorial order) := by ring
+        _ = _ := by rw [mul_descFactorial_eq]; ring
+
+theorem binomialAverage_power {rate : ENNReal} (hrate : rate ≤ 1) (steps degree : Nat) :
+    binomialAverage rate steps (fun count => (count : ENNReal) ^ degree) =
+      ∑ order ∈ Finset.range (degree + 1),
+        (Nat.stirlingSecond degree order : ENNReal) *
+          (steps.descFactorial order : ENNReal) * rate ^ order := by
+  have hpower (count : Nat) : (count : ENNReal) ^ degree =
+      ∑ order ∈ Finset.range (degree + 1),
+        (Nat.stirlingSecond degree order : ENNReal) * (count.descFactorial order : ENNReal) := by
+    exact_mod_cast power_eq_stirling_descFactorial count degree
+  simp_rw [hpower]
+  rw [binomialAverage_sum]
+  apply Finset.sum_congr rfl
+  intro order _
+  rw [binomialAverage_mul_left, binomialAverage_descFactorial hrate]
+  ring
+
+theorem stirlingSecond_le_choose_mul_pow (degree order : Nat) :
+    Nat.stirlingSecond degree order ≤ degree.choose order * degree ^ (degree - order) := by
+  induction degree generalizing order with
+  | zero => cases order <;> simp
+  | succ degree ih =>
+      cases order with
+      | zero => simp
+      | succ order =>
+          by_cases hlt : order < degree
+          · have hpow : (order + 1) * degree ^ (degree - (order + 1)) ≤
+                (degree + 1) ^ (degree - order) := by
+              calc
+                _ ≤ (degree + 1) * (degree + 1) ^ (degree - (order + 1)) :=
+                  Nat.mul_le_mul (by omega) (Nat.pow_le_pow_left (Nat.le_succ _) _)
+                _ = _ := by
+                  rw [← pow_succ']
+                  congr 1
+                  omega
+            calc
+              _ = (order + 1) * Nat.stirlingSecond degree (order + 1) +
+                    Nat.stirlingSecond degree order := Nat.stirlingSecond_succ_succ _ _
+              _ ≤ (order + 1) * (degree.choose (order + 1) * degree ^ (degree - (order + 1))) +
+                    degree.choose order * degree ^ (degree - order) :=
+                  Nat.add_le_add (Nat.mul_le_mul_left _ (ih _)) (ih _)
+              _ = degree.choose (order + 1) * ((order + 1) * degree ^ (degree - (order + 1))) +
+                    degree.choose order * degree ^ (degree - order) := by ring
+              _ ≤ degree.choose (order + 1) * (degree + 1) ^ (degree - order) +
+                    degree.choose order * (degree + 1) ^ (degree - order) :=
+                  Nat.add_le_add (Nat.mul_le_mul_left _ hpow)
+                    (Nat.mul_le_mul_left _ (Nat.pow_le_pow_left (Nat.le_succ _) _))
+              _ = _ := by
+                  rw [Nat.choose_succ_succ]
+                  simp only [Nat.add_sub_add_right]
+                  ring
+          · by_cases heq : order = degree
+            · subst order; simp [Nat.stirlingSecond_self]
+            · rw [Nat.stirlingSecond_eq_zero_of_lt (by omega)]
+              exact Nat.zero_le _
+
+theorem binomialAverage_power_le {rate : ENNReal} (hrate : rate ≤ 1) (steps degree : Nat) :
+    binomialAverage rate steps (fun count => (count : ENNReal) ^ degree) ≤
+      ((steps : ENNReal) * rate + degree) ^ degree := by
+  rw [binomialAverage_power hrate]
+  calc
+    _ ≤ ∑ order ∈ Finset.range (degree + 1),
+        (degree.choose order : ENNReal) * (degree : ENNReal) ^ (degree - order) *
+          ((steps : ENNReal) * rate) ^ order := by
+      apply Finset.sum_le_sum
+      intro order _
+      have hc : (Nat.stirlingSecond degree order : ENNReal) ≤
+          (degree.choose order : ENNReal) * (degree : ENNReal) ^ (degree - order) := by
+        exact_mod_cast stirlingSecond_le_choose_mul_pow degree order
+      have hf : (steps.descFactorial order : ENNReal) ≤ (steps : ENNReal) ^ order := by
+        exact_mod_cast Nat.descFactorial_le_pow steps order
+      apply (mul_le_mul' (mul_le_mul' hc hf) le_rfl).trans_eq
+      rw [mul_pow]
+      ring
+    _ = _ := by
+      rw [add_pow]
+      apply Finset.sum_congr rfl
+      intro order _
+      ring
+
+theorem binomialAverage_shifted_power (rate shift : ENNReal) (steps degree : Nat) :
+    binomialAverage rate steps (fun count => (shift + count) ^ degree) =
+      ∑ order ∈ Finset.range (degree + 1),
+        (degree.choose order : ENNReal) * shift ^ (degree - order) *
+          binomialAverage rate steps (fun count => (count : ENNReal) ^ order) := by
+  have hpower (count : Nat) : (shift + count) ^ degree =
+      ∑ order ∈ Finset.range (degree + 1),
+        (degree.choose order : ENNReal) * shift ^ (degree - order) * (count : ENNReal) ^ order := by
+    rw [add_comm shift, add_pow]
+    apply Finset.sum_congr rfl
+    intro order _
+    ring
+  simp_rw [hpower]
+  rw [binomialAverage_sum]
+  simp_rw [binomialAverage_mul_left]
+
+theorem binomialAverage_shifted_power_le {rate : ENNReal} (hrate : rate ≤ 1)
+    (shift : ENNReal) (steps degree : Nat) :
+    binomialAverage rate steps (fun count => (shift + count) ^ degree) ≤
+      (shift + steps * rate + degree) ^ degree := by
+  rw [binomialAverage_shifted_power]
+  calc
+    _ ≤ ∑ order ∈ Finset.range (degree + 1),
+        (degree.choose order : ENNReal) * shift ^ (degree - order) *
+          ((steps : ENNReal) * rate + degree) ^ order := by
+      apply Finset.sum_le_sum
+      intro order horder
+      have ho : order ≤ degree := Nat.le_of_lt_succ (Finset.mem_range.mp horder)
+      exact mul_le_mul' le_rfl ((binomialAverage_power_le hrate steps order).trans
+        (pow_le_pow_left' (add_le_add le_rfl (Nat.cast_le.mpr ho)) _))
+    _ = _ := by
+      rw [show shift + steps * rate + degree = steps * rate + degree + shift by ac_rfl, add_pow]
+      apply Finset.sum_congr rfl
+      intro order _
+      ring
+
+theorem binomialAverage_power_mono_of_factorial {rate nextRate : ENNReal}
+    (hrate : rate ≤ 1) (hnext : nextRate ≤ 1) (steps nextSteps degree : Nat)
+    (hmoments : ∀ order, order ≤ degree →
+      (steps.descFactorial order : ENNReal) * rate ^ order ≤
+        (nextSteps.descFactorial order : ENNReal) * nextRate ^ order) :
+    binomialAverage rate steps (fun count => (count : ENNReal) ^ degree) ≤
+      binomialAverage nextRate nextSteps (fun count => (count : ENNReal) ^ degree) := by
+  rw [binomialAverage_power hrate, binomialAverage_power hnext]
+  apply Finset.sum_le_sum
+  intro order horder
+  simp only [mul_assoc]
+  exact mul_le_mul' le_rfl (hmoments order (Nat.le_of_lt_succ (Finset.mem_range.mp horder)))
+
+theorem binomialAverage_shifted_power_mono_of_factorial {rate nextRate shift nextShift : ENNReal}
+    (hrate : rate ≤ 1) (hnext : nextRate ≤ 1) (hshift : shift ≤ nextShift)
+    (steps nextSteps degree : Nat)
+    (hmoments : ∀ order, order ≤ degree →
+      (steps.descFactorial order : ENNReal) * rate ^ order ≤
+        (nextSteps.descFactorial order : ENNReal) * nextRate ^ order) :
+    binomialAverage rate steps (fun count => (shift + count) ^ degree) ≤
+      binomialAverage nextRate nextSteps (fun count => (nextShift + count) ^ degree) := by
+  apply (binomialAverage_mono rate steps (fun count =>
+    pow_le_pow_left' (add_le_add hshift (le_rfl (a := (count : ENNReal)))) degree)).trans
+  rw [binomialAverage_shifted_power, binomialAverage_shifted_power]
+  apply Finset.sum_le_sum
+  intro order horder
+  apply mul_le_mul' le_rfl
+  exact binomialAverage_power_mono_of_factorial hrate hnext steps nextSteps order
+    (fun j hj => hmoments j (hj.trans (Nat.le_of_lt_succ (Finset.mem_range.mp horder))))
+
+theorem mass_pow_le_descFactorial (mass : ENNReal) (count degree : Nat)
+    (hroom : mass + degree ≤ ((count + 1 : Nat) : ENNReal)) :
+    mass ^ degree ≤ (count.descFactorial degree : ENNReal) := by
+  have hdegree : degree ≤ count + 1 := Nat.cast_le.mp ((le_add_left le_rfl).trans hroom)
+  have hcancel : ((count + 1 - degree : Nat) : ENNReal) + degree = ((count + 1 : Nat) : ENNReal) := by
+    exact_mod_cast Nat.sub_add_cancel hdegree
+  have hmass : mass ≤ ((count + 1 - degree : Nat) : ENNReal) :=
+    ENNReal.le_of_add_le_add_right (by finiteness) (hroom.trans_eq hcancel.symm)
+  apply (pow_le_pow_left' hmass degree).trans
+  exact_mod_cast Nat.pow_sub_le_descFactorial count degree
+
+theorem binomialAverage_shifted_power_le_of_room {rate nextRate shift nextShift mass : ENNReal}
+    (hrate : rate ≤ 1) (hnext : nextRate ≤ 1) (hshift : shift ≤ nextShift)
+    (steps nextSteps degree : Nat)
+    (hmean : (steps : ENNReal) * rate ≤ mass * nextRate)
+    (hroom : mass + degree ≤ ((nextSteps + 1 : Nat) : ENNReal)) :
+    binomialAverage rate steps (fun count => (shift + count) ^ degree) ≤
+      binomialAverage nextRate nextSteps (fun count => (nextShift + count) ^ degree) := by
+  apply binomialAverage_shifted_power_mono_of_factorial hrate hnext hshift steps nextSteps degree
+  intro order horder
+  have hfall : (steps.descFactorial order : ENNReal) ≤ (steps : ENNReal) ^ order := by
+    exact_mod_cast Nat.descFactorial_le_pow steps order
+  calc
+    _ ≤ (steps : ENNReal) ^ order * rate ^ order := mul_le_mul' hfall le_rfl
+    _ = ((steps : ENNReal) * rate) ^ order := (mul_pow _ _ _).symm
+    _ ≤ (mass * nextRate) ^ order := pow_le_pow_left' hmean order
+    _ = mass ^ order * nextRate ^ order := mul_pow _ _ _
+    _ ≤ _ := mul_le_mul'
+      (mass_pow_le_descFactorial mass nextSteps order
+        ((add_le_add le_rfl (Nat.cast_le.mpr horder)).trans hroom)) le_rfl
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/FinitePmfProductObservation.lean b/formal/sphincs/SphincsSecurity/Proof/Base/FinitePmfProductObservation.lean
new file mode 100644
index 000000000..8d09a6e51
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/FinitePmfProductObservation.lean
@@ -0,0 +1,92 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Base.FirstSuccessFamily
+namespace SphincsSecurity.Concrete.FinitePmfProduct
+
+open _root_.OracleComp ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+variable {Index Value : Type} [Fintype Index] [DecidableEq Index] [Fintype Value]
+
+theorem marginal (family : Index → PMF Value) (index : Index) :
+    (law family).map (fun values => values index) = family index := by
+  letI : DecidableEq Value := Classical.decEq Value
+  apply PMF.ext
+  intro value
+  have hfactor (values : Index → Value) :
+      (if value = values index then law family values else 0) =
+        ∏ other, if other = index then
+          (if value = values other then family other (values other) else 0) else family other (values other) := by
+    by_cases hvalue : value = values index
+    · rw [if_pos hvalue, apply]
+      apply Finset.prod_congr rfl
+      intro other _
+      by_cases hother : other = index
+      · subst other
+        simp only [if_true, hvalue]
+      · simp only [hother, if_false]
+    · rw [if_neg hvalue]
+      symm
+      exact Finset.prod_eq_zero (Finset.mem_univ index) (by simp only [if_true, hvalue, if_false])
+  rw [PMF.map_apply, tsum_fintype]
+  trans ∑ values : Index → Value, ∏ other, if other = index then
+    (if value = values other then family other (values other) else 0) else family other (values other)
+  · exact Finset.sum_congr rfl (fun values _ => hfactor values)
+  rw [← Fintype.prod_sum (fun other (candidate : Value) =>
+    if other = index then (if value = candidate then family other candidate else 0) else family other candidate),
+    Finset.prod_eq_single index]
+  · simp only [if_true]
+    simp
+  · intro other _ hother
+    simp only [hother, if_false]
+    simpa only [tsum_fintype] using PMF.tsum_coe (family other)
+  · simp
+
+theorem fin_succ {n : Nat} (family : Fin (n + 1) → PMF Value) :
+    law family = (family 0).bind (fun first => (law (fun index : Fin n => family index.succ)).map (Fin.cons first)) := by
+  letI : DecidableEq Value := Classical.decEq Value
+  apply PMF.ext
+  intro values
+  have hmap (first : Value) :
+      (law (fun index : Fin n => family index.succ)).map (Fin.cons first) values =
+        if first = values 0 then law (fun index : Fin n => family index.succ) (Fin.tail values) else 0 := by
+    rw [PMF.map_apply]
+    by_cases hfirst : first = values 0
+    · rw [if_pos hfirst, tsum_eq_single (Fin.tail values)]
+      · rw [hfirst, Fin.cons_self_tail, if_pos rfl]
+      · intro tail htail
+        exact if_neg (fun h => htail (by simpa using (congrArg Fin.tail h).symm))
+    · rw [if_neg hfirst]
+      apply ENNReal.tsum_eq_zero.mpr
+      intro tail
+      exact if_neg (fun h => hfirst (by simpa using (congrFun h 0).symm))
+  rw [PMF.bind_apply]
+  simp only [hmap, mul_ite, mul_zero]
+  rw [tsum_eq_single (values 0)]
+  · simp only [if_true, apply, Fin.prod_univ_succ, Fin.tail]
+  · intro value hvalue
+    exact if_neg hvalue
+
+theorem update_apply (family : Index → PMF Value) (index : Index) (replacement : PMF Value)
+    (values : Index → Value) :
+    law (Function.update family index replacement) values =
+      replacement (values index) * ∏ other ∈ Finset.univ.erase index, family other (values other) := by
+  rw [apply, ← Finset.mul_prod_erase Finset.univ
+    (fun other => Function.update family index replacement other (values other)) (Finset.mem_univ index)]
+  rw [Function.update_self]
+  congr 1
+  apply Finset.prod_congr rfl
+  intro other hother
+  rw [Function.update_of_ne (Finset.mem_erase.mp hother).1]
+
+theorem observe_mass [DecidableEq Value] (family : Index → PMF Value) (index : Index) (value : Value) (values : Index → Value) :
+    family index value * law (Function.update family index (PMF.pure value)) values =
+      if values index = value then law family values else 0 := by
+  classical
+  rw [update_apply, apply, ← Finset.mul_prod_erase Finset.univ
+    (fun other => family other (values other)) (Finset.mem_univ index)]
+  by_cases hvalue : values index = value
+  · simp only [hvalue, PMF.pure_apply_self, one_mul, if_true]
+  · simp only [PMF.pure_apply, if_false, zero_mul, mul_zero, hvalue]
+
+end SphincsSecurity.Concrete.FinitePmfProduct
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/FirstSuccessFamily.lean b/formal/sphincs/SphincsSecurity/Proof/Base/FirstSuccessFamily.lean
new file mode 100644
index 000000000..bb99ea979
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/FirstSuccessFamily.lean
@@ -0,0 +1,84 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Base.FirstSuccessTable
+import SphincsSecurity.Statement
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+namespace FinitePmfProduct
+
+variable {Index Value : Type} [Fintype Index] [DecidableEq Index] [Fintype Value]
+
+noncomputable def law (family : Index → PMF Value) : PMF (Index → Value) :=
+  PMF.ofFintype (fun values => ∏ index, family index (values index)) (by
+    rw [← Fintype.prod_sum]
+    apply Finset.prod_eq_one
+    intro index _
+    simpa only [tsum_fintype] using PMF.tsum_coe (family index))
+
+theorem apply (family : Index → PMF Value) (values : Index → Value) :
+    law family values = ∏ index, family index (values index) := rfl
+
+theorem uniform [Nonempty Value] :
+    law (fun _ : Index => PMF.uniformOfFintype Value) = PMF.uniformOfFintype (Index → Value) := by
+  apply PMF.ext
+  intro values
+  simp only [apply, PMF.uniformOfFintype_apply, Finset.prod_const, Finset.card_univ,
+    Fintype.card_fun, Nat.cast_pow, ENNReal.inv_pow]
+
+end FinitePmfProduct
+
+namespace FirstSuccessFamily
+
+variable {Index Answer Value : Type} [Fintype Index] [DecidableEq Index]
+  [Fintype Answer] [DecidableEq Answer] [Nonempty Answer] [Fintype Value]
+
+def select (decode : Answer → Option Value) (n : Nat) (tables : Index → Fin n → Answer) :
+    Index → Option (Fin n × Value) := fun index => FirstSuccessTable.select decode (tables index)
+
+noncomputable def selected (decode : Answer → Option Value) (n : Nat) :
+    PMF (Index → Option (Fin n × Value)) :=
+  FinitePmfProduct.law (fun _ => FirstSuccessTable.selected decode n)
+
+noncomputable def afterSelect (decode : Answer → Option Value) (n : Nat)
+    (hinvalid : (FirstSuccessTable.invalid decode).Nonempty) (results : Index → Option (Fin n × Value)) :
+    PMF (Index → Fin n → Answer) :=
+  FinitePmfProduct.law (fun index => FirstSuccessTable.afterSelect decode n hinvalid (results index))
+
+theorem selected_mul_afterSelect (decode : Answer → Option Value) (n : Nat)
+    (hinvalid : (FirstSuccessTable.invalid decode).Nonempty) (results : Index → Option (Fin n × Value))
+    (tables : Index → Fin n → Answer) :
+    selected decode n results * afterSelect decode n hinvalid results tables =
+      if select decode n tables = results then PMF.uniformOfFintype (Index → Fin n → Answer) tables else 0 := by
+  rw [selected, afterSelect, FinitePmfProduct.apply, FinitePmfProduct.apply, ← Finset.prod_mul_distrib]
+  simp only [FirstSuccessTable.selected_mul_afterSelect]
+  by_cases h : select decode n tables = results
+  · rw [if_pos h]
+    have hcoordinate (index : Index) : FirstSuccessTable.select decode (tables index) = results index := congrFun h index
+    simp only [hcoordinate, if_true, FirstSuccessTable.full_eq_uniform]
+    exact congrFun (congrArg DFunLike.coe (FinitePmfProduct.uniform (Index := Index) (Value := Fin n → Answer))) tables
+  · rw [if_neg h]
+    have hex : ∃ index, FirstSuccessTable.select decode (tables index) ≠ results index := by
+      by_contra! hall
+      exact h (funext hall)
+    obtain ⟨index, hindex⟩ := hex
+    exact Finset.prod_eq_zero (Finset.mem_univ index) (if_neg hindex)
+
+theorem uniform_bind_eq_selected {Result : Type} (decode : Answer → Option Value) (n : Nat)
+    (hinvalid : (FirstSuccessTable.invalid decode).Nonempty)
+    (next : (Index → Option (Fin n × Value)) → (Index → Fin n → Answer) → PMF Result) :
+    (PMF.uniformOfFintype (Index → Fin n → Answer)).bind (fun tables => next (select decode n tables) tables) =
+      (selected decode n).bind (fun results => (afterSelect decode n hinvalid results).bind (next results)) := by
+  apply PMF.ext
+  intro output
+  simp only [PMF.bind_apply, ← ENNReal.tsum_mul_left, ← mul_assoc, selected_mul_afterSelect,
+    ite_mul, zero_mul]
+  rw [ENNReal.tsum_comm]
+  simp
+
+end FirstSuccessFamily
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/FirstSuccessPrefix.lean b/formal/sphincs/SphincsSecurity/Proof/Base/FirstSuccessPrefix.lean
new file mode 100644
index 000000000..f31842785
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/FirstSuccessPrefix.lean
@@ -0,0 +1,136 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Base.FirstSuccessFamily
+import SphincsSecurity.Proof.Fts.UnrestrictedRowSwap
+namespace SphincsSecurity.Concrete.FirstSuccessPrefix
+
+open ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+variable {Index Cell Answer Value : Type}
+
+def kept {n : Nat} (result : Option (Fin n × Value)) (coordinate : Fin n) : Prop :=
+  result.elim True (fun selected => coordinate ≤ selected.1)
+
+def familyKept {n : Nat} (results : Index → Option (Fin n × Value)) (row : Index × Fin n) : Prop :=
+  kept (results row.1) row.2
+
+theorem select_eq_of_kept (decode : Answer → Option Value) {n : Nat} (left right : Fin n → Answer)
+    (result : Option (Fin n × Value)) (hselect : FirstSuccessTable.select decode left = result)
+    (hkept : ∀ coordinate, kept result coordinate → left coordinate = right coordinate) :
+    FirstSuccessTable.select decode right = result := by
+  cases result with
+  | none =>
+      apply (FirstSuccessTable.select_none_iff decode right).mpr
+      intro coordinate
+      rw [← hkept coordinate trivial]
+      exact (FirstSuccessTable.select_none_iff decode left).mp hselect coordinate
+  | some result =>
+      rcases result with ⟨index, value⟩
+      have h := (FirstSuccessTable.select_some_iff decode left index value).mp hselect
+      apply (FirstSuccessTable.select_some_iff decode right index value).mpr
+      constructor
+      · rw [← hkept index (Nat.le_refl _)]
+        exact h.1
+      · intro coordinate hlt
+        rw [← hkept coordinate hlt.le]
+        exact h.2 coordinate hlt
+
+theorem kept_nonselected_invalid (decode : Answer → Option Value) {n : Nat} (table : Fin n → Answer)
+    (result : Option (Fin n × Value)) (hselect : FirstSuccessTable.select decode table = result)
+    (coordinate : Fin n) (hkept : kept result coordinate) (hnot : result.map Prod.fst ≠ some coordinate) :
+    decode (table coordinate) = none := by
+  cases result with
+  | none => exact (FirstSuccessTable.select_none_iff decode table).mp hselect coordinate
+  | some result =>
+      rcases result with ⟨index, value⟩
+      have hle : coordinate ≤ index := hkept
+      have hne : coordinate ≠ index := by
+        intro heq
+        subst coordinate
+        exact hnot rfl
+      exact ((FirstSuccessTable.select_some_iff decode table index value).mp hselect).2 coordinate (lt_of_le_of_ne hle hne)
+
+variable [Fintype Answer] [DecidableEq Answer] [Nonempty Answer]
+
+theorem afterSelect_congr (decode : Answer → Option Value) (n : Nat)
+    (hinvalid : (FirstSuccessTable.invalid decode).Nonempty) (result : Option (Fin n × Value))
+    (left right : Fin n → Answer) (hkept : ∀ coordinate, kept result coordinate → left coordinate = right coordinate) :
+    FirstSuccessTable.afterSelect decode n hinvalid result left =
+      FirstSuccessTable.afterSelect decode n hinvalid result right := by
+  cases result with
+  | none =>
+      have heq : left = right := funext (fun coordinate => hkept coordinate trivial)
+      rw [heq]
+  | some result =>
+      rcases result with ⟨index, value⟩
+      simp only [FirstSuccessTable.afterSelect]
+      split
+      · simp only [FirstSuccessTable.conditional, uniformTable_apply]
+        congr 1
+        apply propext
+        apply forall_congr'
+        intro coordinate
+        by_cases hk : coordinate ≤ index
+        · rw [hkept coordinate hk]
+        · have hlt : ¬coordinate < index := fun h => hk h.le
+          have hne : coordinate ≠ index := fun h => hk h.le
+          simp only [FirstSuccessTable.allowed, if_neg hlt, if_neg hne, Finset.mem_univ]
+      · simp only [FirstSuccessTable.full_eq_uniform, PMF.uniformOfFintype_apply]
+
+variable [Fintype Index] [DecidableEq Index]
+
+noncomputable def familyRows (decode : Answer → Option Value) (n : Nat)
+    (hinvalid : (FirstSuccessTable.invalid decode).Nonempty) (results : Index → Option (Fin n × Value)) :
+    PMF (Index × Fin n → Answer) :=
+  (FirstSuccessFamily.afterSelect decode n hinvalid results).map Function.uncurry
+
+omit [DecidableEq Answer] in
+theorem familyRows_apply (decode : Answer → Option Value) (n : Nat)
+    (hinvalid : (FirstSuccessTable.invalid decode).Nonempty) (results : Index → Option (Fin n × Value))
+    (rows : Index × Fin n → Answer) :
+    familyRows decode n hinvalid results rows =
+      FirstSuccessFamily.afterSelect decode n hinvalid results (Function.curry rows) := by
+  rw [familyRows, PMF.map_apply, tsum_eq_single (Function.curry rows)]
+  · simp only [Function.uncurry_curry, if_true]
+  · intro other hne
+    apply if_neg
+    intro heq
+    apply hne
+    funext index coordinate
+    exact (congrFun heq (index, coordinate)).symm
+
+theorem familyRows_congr (decode : Answer → Option Value) (n : Nat)
+    (hinvalid : (FirstSuccessTable.invalid decode).Nonempty) (results : Index → Option (Fin n × Value))
+    (left right : Index × Fin n → Answer) (hkept : ∀ row, familyKept results row → left row = right row) :
+    familyRows decode n hinvalid results left = familyRows decode n hinvalid results right := by
+  simp only [familyRows_apply, FirstSuccessFamily.afterSelect, FinitePmfProduct.apply]
+  apply Finset.prod_congr rfl
+  intro index _
+  exact afterSelect_congr decode n hinvalid (results index) _ _ (fun coordinate hk => hkept (index, coordinate) hk)
+
+variable [Fintype Cell] [DecidableEq Cell]
+
+theorem overwrite_eq_prefix (decode : Answer → Option Value) (n : Nat)
+    (hinvalid : (FirstSuccessTable.invalid decode).Nonempty) (results : Index → Option (Fin n × Value))
+    (embed : Index × Fin n → Cell) (hinj : Function.Injective embed) :
+    (familyRows decode n hinvalid results).bind (fun rows => (PMF.uniformOfFintype (Cell → Answer)).map
+      (fun seed => ((fun row : {row // familyKept results row} => rows row.val), UniformTableSplit.overwrite embed hinj rows seed))) =
+    (familyRows decode n hinvalid results).bind (fun rows => (PMF.uniformOfFintype (Cell → Answer)).map
+      (fun seed => ((fun row : {row // familyKept results row} => rows row.val),
+        UnrestrictedRowSwap.prefixOverwrite embed hinj (familyKept results) rows seed))) :=
+  UnrestrictedRowSwap.overwrite_eq_prefix embed hinj (familyKept results) _ (familyRows_congr decode n hinvalid results)
+
+theorem overwrite_table_eq_prefix (decode : Answer → Option Value) (n : Nat)
+    (hinvalid : (FirstSuccessTable.invalid decode).Nonempty) (results : Index → Option (Fin n × Value))
+    (embed : Index × Fin n → Cell) (hinj : Function.Injective embed) :
+    (FirstSuccessFamily.afterSelect decode n hinvalid results).bind
+      (fun rows => (PMF.uniformOfFintype (Cell → Answer)).map
+        (UniformTableSplit.overwrite embed hinj (Function.uncurry rows))) =
+    (FirstSuccessFamily.afterSelect decode n hinvalid results).bind
+      (fun rows => (PMF.uniformOfFintype (Cell → Answer)).map
+        (UnrestrictedRowSwap.prefixOverwrite embed hinj (familyKept results) (Function.uncurry rows))) := by
+  have h := congrArg (fun law => PMF.map Prod.snd law) (overwrite_eq_prefix decode n hinvalid results embed hinj)
+  simpa only [PMF.map_bind, PMF.map_comp, Function.comp_def, familyRows, PMF.bind_map] using h
+
+end SphincsSecurity.Concrete.FirstSuccessPrefix
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/FirstSuccessTable.lean b/formal/sphincs/SphincsSecurity/Proof/Base/FirstSuccessTable.lean
new file mode 100644
index 000000000..c084b90b8
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/FirstSuccessTable.lean
@@ -0,0 +1,226 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Base.UniformTableConditioning
+namespace SphincsSecurity.Concrete.FirstSuccessTable
+
+open _root_.OracleComp ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+variable {Answer Value : Type}
+
+def select (decode : Answer → Option Value) : {n : Nat} → (Fin n → Answer) → Option (Fin n × Value)
+  | 0, _ => none
+  | n + 1, table =>
+      match decode (table 0) with
+      | some value => some (0, value)
+      | none => (select decode (fun i : Fin n => table i.succ)).map (fun result => (result.1.succ, result.2))
+
+theorem select_none_iff (decode : Answer → Option Value) {n : Nat} (table : Fin n → Answer) :
+    select decode table = none ↔ ∀ i, decode (table i) = none := by
+  induction n with
+  | zero => simp [select]
+  | succ n ih =>
+      rw [select, Fin.forall_fin_succ]
+      cases hzero : decode (table 0) <;> simp [ih]
+
+theorem select_some_iff (decode : Answer → Option Value) {n : Nat} (table : Fin n → Answer)
+    (index : Fin n) (value : Value) :
+    select decode table = some (index, value) ↔
+      decode (table index) = some value ∧ ∀ i, i < index → decode (table i) = none := by
+  induction n with
+  | zero => exact Fin.elim0 index
+  | succ n ih =>
+      refine Fin.cases ?_ (fun index => ?_) index
+      · rw [select]
+        cases hzero : decode (table 0) with
+        | none =>
+            simp only [Option.map_eq_some_iff, Prod.mk.injEq]
+            constructor
+            · rintro ⟨⟨i, result⟩, _, hi, _⟩
+              exact (Fin.succ_ne_zero i hi).elim
+            · simp
+        | some result => simp
+      · rw [select]
+        cases hzero : decode (table 0) with
+        | none =>
+            simp only [Option.map_eq_some_iff, Prod.mk.injEq, Fin.succ_inj]
+            constructor
+            · rintro ⟨⟨i, result⟩, hselected, hi, hv⟩
+              dsimp only at hi hv
+              subst i
+              subst result
+              obtain ⟨hvalue, hbefore⟩ := (ih _ _).mp hselected
+              refine ⟨hvalue, ?_⟩
+              intro i
+              refine Fin.cases (fun _ => hzero) (fun i hi => hbefore i (by simpa using hi)) i
+            · rintro ⟨hvalue, hbefore⟩
+              refine ⟨(index, value), (ih _ _).mpr ⟨hvalue, ?_⟩, rfl, rfl⟩
+              intro i hi
+              exact hbefore i.succ (by simpa using hi)
+        | some result =>
+            constructor
+            · intro h
+              have hindex := congrArg (fun result => result.map (fun pair => pair.1.val)) h
+              simp at hindex
+            · rintro ⟨_, hbefore⟩
+              have h := hbefore 0 (by simp)
+              simp [hzero] at h
+
+variable [Fintype Answer] [DecidableEq Answer]
+
+noncomputable def invalid (decode : Answer → Option Value) : Finset Answer :=
+  Finset.univ.filter (fun answer => decode answer = none)
+
+noncomputable def fiber (decode : Answer → Option Value) (value : Value) : Finset Answer :=
+  Finset.univ.filter (fun answer => decode answer = some value)
+
+omit [DecidableEq Answer] in
+@[simp] theorem mem_invalid (decode : Answer → Option Value) (answer : Answer) :
+    answer ∈ invalid decode ↔ decode answer = none := by simp [invalid]
+
+omit [DecidableEq Answer] in
+@[simp] theorem mem_fiber (decode : Answer → Option Value) (value : Value) (answer : Answer) :
+    answer ∈ fiber decode value ↔ decode answer = some value := by simp [fiber]
+
+noncomputable def allowed (decode : Answer → Option Value) {n : Nat} (index : Fin n) (value : Value)
+    (coordinate : Fin n) : Finset Answer :=
+  if coordinate < index then invalid decode else if coordinate = index then fiber decode value else Finset.univ
+
+omit [DecidableEq Answer] in
+theorem allowed_nonempty (decode : Answer → Option Value) {n : Nat} (index : Fin n) (value : Value)
+    (hinvalid : (invalid decode).Nonempty) (hvalue : (fiber decode value).Nonempty) :
+    ∀ coordinate, (allowed decode index value coordinate).Nonempty := by
+  intro coordinate
+  unfold allowed
+  split_ifs
+  · exact hinvalid
+  · exact hvalue
+  · exact Finset.univ_nonempty_iff.mpr ⟨hinvalid.choose⟩
+
+omit [DecidableEq Answer] in
+theorem select_some_iff_allowed (decode : Answer → Option Value) {n : Nat} (table : Fin n → Answer)
+    (index : Fin n) (value : Value) :
+    select decode table = some (index, value) ↔
+      ∀ coordinate, table coordinate ∈ allowed decode index value coordinate := by
+  rw [select_some_iff]
+  constructor
+  · rintro ⟨hvalue, hbefore⟩ coordinate
+    unfold allowed
+    split_ifs with hlt heq
+    · exact (mem_invalid _ _).mpr (hbefore coordinate hlt)
+    · subst coordinate
+      exact (mem_fiber _ _ _).mpr hvalue
+    · exact Finset.mem_univ _
+  · intro h
+    refine ⟨?_, ?_⟩
+    · simpa [allowed] using h index
+    · intro coordinate hlt
+      simpa [allowed, hlt] using h coordinate
+
+noncomputable def full (n : Nat) [Nonempty Answer] : PMF (Fin n → Answer) :=
+  uniformTable (fun _ => Finset.univ) (fun _ => Finset.univ_nonempty)
+
+omit [DecidableEq Answer] in
+theorem full_eq_uniform (n : Nat) [Nonempty Answer] :
+    full (Answer := Answer) n = PMF.uniformOfFintype (Fin n → Answer) := by
+  unfold full uniformTable PMF.uniformOfFintype
+  congr 1
+
+noncomputable def conditional (decode : Answer → Option Value) {n : Nat} (index : Fin n) (value : Value)
+    (hinvalid : (invalid decode).Nonempty) (hvalue : (fiber decode value).Nonempty) : PMF (Fin n → Answer) :=
+  uniformTable (allowed decode index value) (allowed_nonempty decode index value hinvalid hvalue)
+
+noncomputable def successMass (decode : Answer → Option Value) {n : Nat} (index : Fin n) (value : Value) : ENNReal :=
+  ((∏ coordinate, (allowed decode index value coordinate).card : Nat) : ENNReal) /
+    ((∏ _coordinate : Fin n, Fintype.card Answer : Nat) : ENNReal)
+
+theorem full_success_mass [Nonempty Answer] (decode : Answer → Option Value) {n : Nat}
+    (index : Fin n) (value : Value) (hinvalid : (invalid decode).Nonempty)
+    (hvalue : (fiber decode value).Nonempty) (table : Fin n → Answer) :
+    (if select decode table = some (index, value) then full n table else 0) =
+      successMass decode index value * conditional decode index value hinvalid hvalue table := by
+  simp only [select_some_iff_allowed]
+  have h := uniformTable_restrict (fun _ : Fin n => Finset.univ) (allowed decode index value)
+      (fun _ => Finset.univ_nonempty) (allowed_nonempty decode index value hinvalid hvalue)
+      (fun _ => Finset.subset_univ _) table
+  by_cases ht : ∀ coordinate, table coordinate ∈ allowed decode index value coordinate <;>
+    simpa only [full, successMass, conditional, Finset.card_univ, ht, if_true, if_false] using h
+
+theorem probEvent_full_success [Nonempty Answer] (decode : Answer → Option Value) {n : Nat}
+    (index : Fin n) (value : Value) (hinvalid : (invalid decode).Nonempty)
+    (hvalue : (fiber decode value).Nonempty) :
+    Pr[fun table => select decode table = some (index, value) | full (Answer := Answer) n] =
+      successMass decode index value := by
+  simp only [probEvent_eq_tsum_ite, PMF.probOutput_eq_apply,
+    full_success_mass decode index value hinvalid hvalue, ENNReal.tsum_mul_left, PMF.tsum_coe, mul_one]
+
+noncomputable def exhausted (decode : Answer → Option Value) (n : Nat)
+    (hinvalid : (invalid decode).Nonempty) : PMF (Fin n → Answer) :=
+  uniformTable (fun _ => invalid decode) (fun _ => hinvalid)
+
+theorem full_exhaustion_mass [Nonempty Answer] (decode : Answer → Option Value) (n : Nat)
+    (hinvalid : (invalid decode).Nonempty) (table : Fin n → Answer) :
+    (if select decode table = none then full n table else 0) =
+      ((invalid decode).card / (Fintype.card Answer : ENNReal)) ^ n * exhausted decode n hinvalid table := by
+  have h := uniformTable_restrict (fun _ : Fin n => Finset.univ) (fun _ => invalid decode)
+    (fun _ => Finset.univ_nonempty) (fun _ => hinvalid) (fun _ => Finset.subset_univ _) table
+  have hmass :
+      (((∏ _coordinate : Fin n, (invalid decode).card : Nat) : ENNReal) /
+        ((∏ _coordinate : Fin n, (Finset.univ : Finset Answer).card : Nat) : ENNReal)) =
+          ((invalid decode).card / (Fintype.card Answer : ENNReal)) ^ n := by
+    simp only [Finset.prod_const, Finset.card_univ, Fintype.card_fin, Nat.cast_pow,
+      div_eq_mul_inv, ENNReal.inv_pow, mul_pow]
+  rw [hmass] at h
+  simp only [mem_invalid] at h
+  simp only [select_none_iff]
+  by_cases ht : ∀ coordinate, decode (table coordinate) = none <;>
+    simpa only [full, exhausted, ht, if_true, if_false] using h
+
+theorem probEvent_full_exhaustion [Nonempty Answer] (decode : Answer → Option Value) (n : Nat)
+    (hinvalid : (invalid decode).Nonempty) :
+    Pr[fun table => select decode table = none | full (Answer := Answer) n] =
+      ((invalid decode).card / (Fintype.card Answer : ENNReal)) ^ n := by
+  simp only [probEvent_eq_tsum_ite, PMF.probOutput_eq_apply,
+    full_exhaustion_mass decode n hinvalid, ENNReal.tsum_mul_left, PMF.tsum_coe, mul_one]
+
+noncomputable def selected [Nonempty Answer] (decode : Answer → Option Value) (n : Nat) :
+    PMF (Option (Fin n × Value)) := (full n).map (select decode)
+
+noncomputable def afterSelect [Nonempty Answer] (decode : Answer → Option Value) (n : Nat)
+    (hinvalid : (invalid decode).Nonempty) : Option (Fin n × Value) → PMF (Fin n → Answer)
+  | none => exhausted decode n hinvalid
+  | some (index, value) =>
+      if hvalue : (fiber decode value).Nonempty then conditional decode index value hinvalid hvalue else full n
+
+omit [DecidableEq Answer] in
+theorem selected_apply [Nonempty Answer] (decode : Answer → Option Value) (n : Nat)
+    (result : Option (Fin n × Value)) :
+    selected decode n result = Pr[fun table => select decode table = result | full (Answer := Answer) n] := by
+  simp only [selected, PMF.map_apply, probEvent_eq_tsum_ite, PMF.probOutput_eq_apply]
+  apply tsum_congr
+  intro table
+  by_cases h : select decode table = result
+  · subst result
+    simp
+  · simp only [h, Ne.symm h, if_false]
+
+theorem selected_mul_afterSelect [Nonempty Answer] (decode : Answer → Option Value) (n : Nat)
+    (hinvalid : (invalid decode).Nonempty) (result : Option (Fin n × Value)) (table : Fin n → Answer) :
+    selected decode n result * afterSelect decode n hinvalid result table =
+      if select decode table = result then full n table else 0 := by
+  cases result with
+  | none =>
+      rw [selected_apply, probEvent_full_exhaustion decode n hinvalid, afterSelect]
+      exact (full_exhaustion_mass decode n hinvalid table).symm
+  | some result =>
+      obtain ⟨index, value⟩ := result
+      by_cases hvalue : (fiber decode value).Nonempty
+      · rw [selected_apply, probEvent_full_success decode index value hinvalid hvalue,
+          afterSelect, dif_pos hvalue]
+        exact (full_success_mass decode index value hinvalid hvalue table).symm
+      · have hselected : ∀ table : Fin n → Answer, select decode table ≠ some (index, value) := by
+          intro table h
+          exact hvalue ⟨table index, (mem_fiber _ _ _).mpr ((select_some_iff _ _ _ _).mp h).1⟩
+        simp only [selected_apply, probEvent_eq_tsum_ite, hselected, if_false, tsum_zero, zero_mul]
+
+end SphincsSecurity.Concrete.FirstSuccessTable
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/FourthMomentExceptionBound.lean b/formal/sphincs/SphincsSecurity/Proof/Base/FourthMomentExceptionBound.lean
new file mode 100644
index 000000000..fcdfc9dd8
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/FourthMomentExceptionBound.lean
@@ -0,0 +1,34 @@
+import SphincsSecurity.Proof.Base.Prelude
+namespace SphincsSecurity
+
+open OracleComp OracleSpec ENNReal
+
+noncomputable def fourthMomentBudget (q : Nat) (second fourth : ENNReal) : ENNReal :=
+  fourth + 6138 * q * second + 6279174 * q.choose 2 + (2 : ENNReal) ^ 30 * q
+
+theorem fourth_le_fourthMomentBudget (q : Nat) (second fourth : ENNReal) :
+    fourth ≤ fourthMomentBudget q second fourth := by
+  exact ((le_self_add.trans le_self_add).trans le_self_add)
+
+theorem fourthMomentBudget_zero_le (q : Nat) (hq : q ≤ 2 ^ 127) :
+    fourthMomentBudget q 0 0 / (2 : ENNReal) ^ 372 ≤ (q : ENNReal) / 2 ^ 223 := by
+  have hchoose : 2 * q.choose 2 + q = q * q := by
+    clear hq
+    induction q with
+    | zero => simp
+    | succ q ih =>
+        have hstep : (q + 1).choose 2 = q + q.choose 2 := by
+          simpa only [Nat.choose_one_right] using Nat.choose_succ_succ' q 1
+        rw [hstep]
+        nlinarith
+  have hchooseReal : 2 * (q.choose 2 : ℝ) + q = (q : ℝ) * q := by exact_mod_cast hchoose
+  have hqReal : (q : ℝ) ≤ 2 ^ 127 := by exact_mod_cast hq
+  have hqNonneg : (0 : ℝ) ≤ q := Nat.cast_nonneg q
+  have hproduct : (q : ℝ) * q ≤ q * 2 ^ 127 := mul_le_mul_of_nonneg_left hqReal hqNonneg
+  apply (ENNReal.toReal_le_toReal (by simp [fourthMomentBudget]; finiteness) (by finiteness)).mp
+  simp only [fourthMomentBudget, mul_zero, add_zero, zero_add]
+  rw [ENNReal.toReal_div, ENNReal.toReal_add (by finiteness) (by finiteness), ENNReal.toReal_div]
+  norm_num [ENNReal.toReal_mul, ENNReal.toReal_pow, pow_succ] at hproduct ⊢
+  nlinarith
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/Prelude.lean b/formal/sphincs/SphincsSecurity/Proof/Base/Prelude.lean
new file mode 100644
index 000000000..1361d04c0
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/Prelude.lean
@@ -0,0 +1,33 @@
+import Batteries.Data.Fin.Coding
+import Mathlib.Algebra.BigOperators.Group.Finset.Powerset
+import Mathlib.Algebra.BigOperators.Ring.Finset
+import Mathlib.Algebra.FreeMonoid.Basic
+import Mathlib.Algebra.Group.Hom.End
+import Mathlib.Analysis.SpecificLimits.Basic
+import Mathlib.Combinatorics.Enumerative.InclusionExclusion
+import Mathlib.Combinatorics.Enumerative.Stirling
+import Mathlib.Data.BitVec
+import Mathlib.Data.Fin.Tuple.Basic
+import Mathlib.Data.Fintype.BigOperators
+import Mathlib.Data.Fintype.Card
+import Mathlib.Data.Fintype.EquivFin
+import Mathlib.Data.Fintype.Powerset
+import Mathlib.Data.List.GetD
+import Mathlib.Data.List.Infix
+import Mathlib.Data.List.Sort
+import Mathlib.Data.Nat.Choose.Sum
+import Mathlib.Data.Nat.Factorial.Basic
+import Mathlib.Data.Set.Card.Arithmetic
+import Mathlib.Order.Interval.Finset.Fin
+import Mathlib.Probability.Distributions.Poisson.Basic
+import Mathlib.Probability.ProbabilityMassFunction.Constructions
+import Mathlib.RingTheory.Polynomial.Pochhammer
+import Mathlib.Tactic.DeriveFintype
+import Mathlib.Topology.Algebra.InfiniteSum.NatInt
+import VCVio.OracleComp.QueryTracking.LoggingOracle
+import VCVio.OracleComp.QueryTracking.RandomOracle.DeferredSampling
+import VCVio.OracleComp.QueryTracking.RandomOracle.EagerTable
+import VCVio.OracleComp.QueryTracking.SubSpec
+import VCVio.ProgramLogic.Relational.ProgrammingOracle
+import VCVio.ProgramLogic.Relational.Quantitative
+
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/QueryCap.lean b/formal/sphincs/SphincsSecurity/Proof/Base/QueryCap.lean
new file mode 100644
index 000000000..55add3a2d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/QueryCap.lean
@@ -0,0 +1,129 @@
+import SphincsSecurity.Proof.Base.Prelude
+namespace SphincsSecurity.QueryCap
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {Index : Type} {spec : OracleSpec Index} {Result Next : Type}
+  (selected : Index → Prop) [DecidablePred selected]
+
+noncomputable def counted (computation : OracleComp spec Result) : OracleComp spec (Result × Nat) :=
+  OracleComp.construct (fun result => pure (result, 0))
+    (fun input _ next => do
+      let answer ← liftM (spec.query input)
+      let result ← next answer
+      pure (result.1, (if selected input then 1 else 0) + result.2)) computation
+
+theorem counted_pure (result : Result) : counted selected (pure result : OracleComp spec Result) = pure (result, 0) := rfl
+
+theorem counted_query_bind (input : spec.Domain) (next : spec.Range input → OracleComp spec Result) :
+    counted selected (liftM (spec.query input) >>= next) = (do
+      let answer ← liftM (spec.query input)
+      let result ← counted selected (next answer)
+      pure (result.1, (if selected input then 1 else 0) + result.2)) := rfl
+
+theorem counted_forget (computation : OracleComp spec Result) :
+    Prod.fst <$> counted selected computation = computation := by
+  induction computation using OracleComp.inductionOn with
+  | pure result => simp only [counted_pure, map_pure]
+  | query_bind input next ih =>
+      simp only [counted_query_bind, map_bind, bind_pure_comp, Functor.map_map, ih]
+
+theorem counted_bind (computation : OracleComp spec Result) (next : Result → OracleComp spec Next) :
+    counted selected (computation >>= next) = (do
+      let first ← counted selected computation
+      let second ← counted selected (next first.1)
+      pure (second.1, first.2 + second.2)) := by
+  induction computation using OracleComp.inductionOn with
+  | pure result => simp only [pure_bind, counted_pure, zero_add, Prod.mk.eta, bind_pure]
+  | query_bind input continuation ih =>
+      simp only [bind_assoc, counted_query_bind, ih, pure_bind, Nat.add_assoc]
+
+theorem counted_map (computation : OracleComp spec Result) (f : Result → Next) :
+    counted selected (f <$> computation) = (fun result => (f result.1, result.2)) <$> counted selected computation := by
+  rw [show f <$> computation = computation >>= fun result => pure (f result) from (bind_pure_comp f computation).symm,
+    counted_bind]
+  simp only [counted_pure, Nat.add_zero, bind_pure_comp, map_pure]
+
+noncomputable def run (computation : OracleComp spec Result) : Nat → OracleComp spec (Option (Result × Nat)) :=
+  OracleComp.construct (fun result budget => pure (some (result, budget)))
+    (fun input _ next budget =>
+      if selected input then
+        match budget with
+        | 0 => pure none
+        | remaining + 1 => liftM (spec.query input) >>= fun answer => next answer remaining
+      else liftM (spec.query input) >>= fun answer => next answer budget) computation
+
+theorem run_pure (result : Result) (budget : Nat) :
+    run selected (pure result : OracleComp spec Result) budget = pure (some (result, budget)) := rfl
+
+theorem run_query_bind (input : spec.Domain) (next : spec.Range input → OracleComp spec Result) (budget : Nat) :
+    run selected (liftM (spec.query input) >>= next) budget =
+      if selected input then
+        match budget with
+        | 0 => pure none
+        | remaining + 1 => liftM (spec.query input) >>= fun answer => run selected (next answer) remaining
+      else liftM (spec.query input) >>= fun answer => run selected (next answer) budget := rfl
+
+theorem run_queryBound (computation : OracleComp spec Result) (budget : Nat) :
+    (run selected computation budget).IsQueryBoundP selected budget := by
+  induction computation using OracleComp.inductionOn generalizing budget with
+  | pure result => simp only [run_pure, isQueryBoundP_pure]
+  | query_bind input next ih =>
+      rw [run_query_bind]
+      by_cases hselected : selected input
+      · rw [if_pos hselected]
+        cases budget with
+        | zero => exact isQueryBoundP_pure selected none 0
+        | succ budget =>
+            simp only [isQueryBoundP_query_bind_iff, hselected, not_true_eq_false, false_or, Nat.zero_lt_succ,
+              ↓reduceIte, Nat.add_sub_cancel, true_and]
+            exact fun answer => ih answer budget
+      · simp only [isQueryBoundP_query_bind_iff, hselected, not_false_eq_true, true_or,
+          ↓reduceIte, true_and]
+        exact fun answer => ih answer budget
+
+theorem run_bind (computation : OracleComp spec Result) (next : Result → OracleComp spec Next) (budget : Nat) :
+    run selected (computation >>= next) budget = (do
+      match ← run selected computation budget with
+      | none => pure none
+      | some result => run selected (next result.1) result.2) := by
+  induction computation using OracleComp.inductionOn generalizing budget with
+  | pure result => simp only [pure_bind, run_pure]
+  | query_bind input continuation ih =>
+      rw [bind_assoc, run_query_bind, run_query_bind]
+      by_cases hselected : selected input
+      · rw [if_pos hselected, if_pos hselected]
+        cases budget with
+        | zero => simp only [pure_bind]
+        | succ budget => simp only [bind_assoc, ih]
+      · simp only [if_neg hselected, bind_assoc, ih]
+
+def finish (budget : Nat) (result : Result × Nat) : Option (Result × Nat) :=
+  if result.2 ≤ budget then some (result.1, budget - result.2) else none
+
+theorem run_eq_counted (impl : QueryImpl spec PMF) (computation : OracleComp spec Result) (budget : Nat) :
+    simulateQ impl (run selected computation budget) =
+      (simulateQ impl (counted selected computation)).map (finish budget) := by
+  induction computation using OracleComp.inductionOn generalizing budget with
+  | pure result =>
+      simp only [run_pure, counted_pure, simulateQ_pure, ← PMF.monad_map_eq_map, map_pure,
+        finish, Nat.zero_le, if_true, Nat.sub_zero]
+  | query_bind input next ih =>
+      rw [run_query_bind, counted_query_bind]
+      by_cases hselected : selected input
+      · rw [if_pos hselected]
+        cases budget with
+        | zero =>
+            simp only [simulateQ_pure, simulateQ_bind, simulateQ_spec_query, PMF.monad_bind_eq_bind,
+              PMF.monad_pure_eq_pure, PMF.map, PMF.bind_bind, PMF.pure_bind, Function.comp_def,
+              finish, if_pos hselected, Nat.add_comm 1, Nat.add_one_le_iff, Nat.not_lt_zero, if_false, PMF.bind_const]
+        | succ budget =>
+            simp only [simulateQ_bind, simulateQ_spec_query, ih, simulateQ_pure, PMF.monad_bind_eq_bind,
+              PMF.monad_pure_eq_pure, PMF.map, PMF.bind_bind, PMF.pure_bind, Function.comp_def, finish, if_pos hselected,
+              Nat.add_comm 1, Nat.add_le_add_iff_right, Nat.add_sub_add_right]
+      · simp only [if_neg hselected, simulateQ_bind, simulateQ_spec_query, ih, simulateQ_pure,
+          PMF.monad_bind_eq_bind, PMF.monad_pure_eq_pure, PMF.map, PMF.bind_bind, PMF.pure_bind, Function.comp_def,
+          Nat.zero_add, Prod.mk.eta]
+
+end SphincsSecurity.QueryCap
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/QueryCapAccounting.lean b/formal/sphincs/SphincsSecurity/Proof/Base/QueryCapAccounting.lean
new file mode 100644
index 000000000..00d6a8263
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/QueryCapAccounting.lean
@@ -0,0 +1,80 @@
+import SphincsSecurity.Proof.Base.QueryCap
+namespace SphincsSecurity.QueryCap
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {Index : Type} {spec : OracleSpec Index} {Result : Type}
+
+theorem simulate_mem_support (impl : QueryImpl spec PMF) (computation : OracleComp spec Result)
+    (result : Result) (hresult : result ∈ (simulateQ impl computation).support) : result ∈ support computation := by
+  induction computation using OracleComp.inductionOn with
+  | pure value =>
+      simp only [simulateQ_pure, PMF.monad_pure_eq_pure, PMF.mem_support_pure_iff] at hresult
+      exact (mem_support_pure_iff _ _).mpr hresult
+  | query_bind input next ih =>
+      simp only [simulateQ_bind, simulateQ_spec_query, PMF.monad_bind_eq_bind, PMF.mem_support_bind_iff] at hresult
+      obtain ⟨answer, _, hresult⟩ := hresult
+      refine (mem_support_bind_iff _ _ _).mpr ⟨answer, ?_, ih answer hresult⟩
+      simp only [support_query, Set.mem_univ]
+
+variable (selected : Index → Prop) [DecidablePred selected]
+
+theorem counted_le_of_queryBound (computation : OracleComp spec Result) (budget : Nat)
+    (hbound : computation.IsQueryBoundP selected budget) (result : Result × Nat)
+    (hresult : result ∈ support (counted selected computation)) : result.2 ≤ budget := by
+  induction computation using OracleComp.inductionOn generalizing budget result with
+  | pure value =>
+      rw [counted_pure, mem_support_pure_iff] at hresult
+      subst result
+      exact Nat.zero_le _
+  | query_bind input next ih =>
+      rw [counted_query_bind, mem_support_bind_iff] at hresult
+      obtain ⟨answer, _, hresult⟩ := hresult
+      rw [mem_support_bind_iff] at hresult
+      obtain ⟨tail, htail, hresult⟩ := hresult
+      rw [mem_support_pure_iff] at hresult
+      subst result
+      rw [isQueryBoundP_query_bind_iff] at hbound
+      have htail := ih answer _ (hbound.2 answer) tail htail
+      by_cases hselected : selected input
+      · have hpos : 0 < budget := by simpa only [hselected, not_true_eq_false, false_or] using hbound.1
+        simp only [if_pos hselected] at htail ⊢
+        omega
+      · simpa only [if_neg hselected, Nat.zero_add] using htail
+
+theorem counted_writer_bind_le {Trace Next : Type} [Monoid Trace] (cost : Trace → Nat)
+    (hcost : ∀ first second, cost (first * second) = cost first + cost second)
+    (first : WriterT Trace (OracleComp spec) Result) (next : Result → WriterT Trace (OracleComp spec) Next)
+    (hfirst : ∀ result ∈ support (counted selected first.run), result.2 ≤ cost result.1.2)
+    (hnext : ∀ value result, result ∈ support (counted selected (next value).run) → result.2 ≤ cost result.1.2)
+    (result : (Next × Trace) × Nat) (hresult : result ∈ support (counted selected (first >>= next).run)) :
+    result.2 ≤ cost result.1.2 := by
+  rw [WriterT.run_bind, counted_bind, mem_support_bind_iff] at hresult
+  obtain ⟨middle, hmiddle, hresult⟩ := hresult
+  rw [counted_map, mem_support_bind_iff] at hresult
+  obtain ⟨last, hlast, hresult⟩ := hresult
+  rw [support_map] at hlast
+  obtain ⟨tail, htail, rfl⟩ := hlast
+  rw [mem_support_pure_iff] at hresult
+  subst result
+  rw [hcost]
+  exact Nat.add_le_add (hfirst middle hmiddle) (hnext middle.1.1 tail htail)
+
+theorem counted_writer_simulate_le {SourceIndex Trace : Type} {source : OracleSpec SourceIndex} [Monoid Trace]
+    (cost : Trace → Nat) (hcost : ∀ first second, cost (first * second) = cost first + cost second)
+    (impl : QueryImpl source (WriterT Trace (OracleComp spec)))
+    (hstep : ∀ input result, result ∈ support (counted selected (impl input).run) → result.2 ≤ cost result.1.2)
+    (computation : OracleComp source Result) (result : (Result × Trace) × Nat)
+    (hresult : result ∈ support (counted selected (simulateQ impl computation).run)) : result.2 ≤ cost result.1.2 := by
+  induction computation using OracleComp.inductionOn generalizing result with
+  | pure value =>
+      simp only [simulateQ_pure, WriterT.run_pure, counted_pure, mem_support_pure_iff] at hresult
+      subst result
+      exact Nat.zero_le _
+  | query_bind input next ih =>
+      rw [simulateQ_bind, simulateQ_spec_query] at hresult
+      exact counted_writer_bind_le selected cost hcost (impl input) (fun answer => simulateQ impl (next answer))
+        (hstep input) ih result hresult
+
+end SphincsSecurity.QueryCap
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/QueryCapBalance.lean b/formal/sphincs/SphincsSecurity/Proof/Base/QueryCapBalance.lean
new file mode 100644
index 000000000..abdebe729
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/QueryCapBalance.lean
@@ -0,0 +1,56 @@
+import SphincsSecurity.Proof.Base.QueryCapAccounting
+namespace SphincsSecurity.QueryCap
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {Index : Type} {spec : OracleSpec Index} {Result : Type}
+  (selected : Index → Prop) [DecidablePred selected]
+
+theorem counted_run_balance (computation : OracleComp spec Result) (budget : Nat)
+    (result : Option (Result × Nat) × Nat) (hresult : result ∈ support (counted selected (run selected computation budget))) :
+    result.2 + result.1.elim 0 Prod.snd = budget := by
+  induction computation using OracleComp.inductionOn generalizing budget result with
+  | pure value =>
+      simp only [run_pure, counted_pure, mem_support_pure_iff] at hresult
+      subst result
+      simp only [Option.elim_some, Nat.zero_add]
+  | query_bind input next ih =>
+      rw [run_query_bind] at hresult
+      by_cases hs : selected input
+      · rw [if_pos hs] at hresult
+        cases budget with
+        | zero =>
+            rw [counted_pure, mem_support_pure_iff] at hresult
+            subst result
+            rfl
+        | succ budget =>
+            rw [counted_query_bind, mem_support_bind_iff] at hresult
+            obtain ⟨answer, _, hresult⟩ := hresult
+            rw [mem_support_bind_iff] at hresult
+            obtain ⟨tail, htail, hresult⟩ := hresult
+            rw [mem_support_pure_iff] at hresult
+            subst result
+            have h := ih answer budget tail htail
+            simp only [if_pos hs]
+            omega
+      · rw [if_neg hs, counted_query_bind, mem_support_bind_iff] at hresult
+        obtain ⟨answer, _, hresult⟩ := hresult
+        rw [mem_support_bind_iff] at hresult
+        obtain ⟨tail, htail, hresult⟩ := hresult
+        rw [mem_support_pure_iff] at hresult
+        subst result
+        simpa only [if_neg hs, Nat.zero_add] using ih answer budget tail htail
+
+theorem counted_next_bound (impl : QueryImpl spec PMF) (input : spec.Domain)
+    (next : spec.Range input → OracleComp spec Result) (budget : Nat)
+    (hbound : ∀ result ∈ (simulateQ impl (counted selected (liftM (spec.query input) >>= next))).support, result.2 ≤ budget)
+    (answer : spec.Range input) (hanswer : answer ∈ (impl input).support)
+    (tail : Result × Nat) (htail : tail ∈ (simulateQ impl (counted selected (next answer))).support) :
+    (if selected input then 1 else 0) + tail.2 ≤ budget := by
+  apply hbound (tail.1, (if selected input then 1 else 0) + tail.2)
+  simp only [counted_query_bind, simulateQ_bind, simulateQ_spec_query, simulateQ_pure,
+    PMF.monad_bind_eq_bind, PMF.monad_pure_eq_pure, PMF.mem_support_bind_iff, PMF.mem_support_pure_iff]
+  exact ⟨answer, hanswer, tail, htail, rfl⟩
+
+end SphincsSecurity.QueryCap
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/QueryCapErasure.lean b/formal/sphincs/SphincsSecurity/Proof/Base/QueryCapErasure.lean
new file mode 100644
index 000000000..59d34e94e
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/QueryCapErasure.lean
@@ -0,0 +1,62 @@
+import SphincsSecurity.Proof.Base.QueryCapAccounting
+namespace SphincsSecurity.QueryCap
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+private theorem map_eq_on_support {Result Output : Type} (law : PMF Result) (first second : Result → Output)
+    (h : ∀ result ∈ law.support, first result = second result) : law.map first = law.map second := by
+  classical
+  apply PMF.ext
+  intro output
+  rw [PMF.map, PMF.map, PMF.bind_apply, PMF.bind_apply]
+  apply tsum_congr
+  intro result
+  simp only [Function.comp_apply]
+  by_cases hresult : result ∈ law.support
+  · rw [h result hresult]
+  · have hzero : law result = 0 := by simpa only [PMF.mem_support_iff, not_not] using hresult
+    simp only [hzero, zero_mul]
+
+variable {Index : Type} {spec : OracleSpec Index} {Result : Type}
+  (selected : Index → Prop) [DecidablePred selected]
+
+theorem counted_simulate_result_mem (impl : QueryImpl spec PMF) (computation : OracleComp spec Result)
+    (result : Result × Nat) (hresult : result ∈ (simulateQ impl (counted selected computation)).support) :
+    result.1 ∈ (simulateQ impl computation).support := by
+  have hmap : (simulateQ impl (counted selected computation)).map Prod.fst = simulateQ impl computation := by
+    rw [← PMF.monad_map_eq_map, ← simulateQ_map, counted_forget]
+  rw [← hmap, PMF.mem_support_map_iff]
+  exact ⟨result, hresult, rfl⟩
+
+theorem run_eq_some_counted (impl : QueryImpl spec PMF) (computation : OracleComp spec Result) (budget : Nat)
+    (hbound : ∀ result ∈ (simulateQ impl (counted selected computation)).support, result.2 ≤ budget) :
+    simulateQ impl (run selected computation budget) =
+      (simulateQ impl (counted selected computation)).map (fun result => some (result.1, budget - result.2)) := by
+  rw [run_eq_counted]
+  apply map_eq_on_support
+  intro result hresult
+  exact if_pos (hbound result hresult)
+
+theorem run_erased (impl : QueryImpl spec PMF) (computation : OracleComp spec Result) (budget : Nat)
+    (hbound : ∀ result ∈ (simulateQ impl (counted selected computation)).support, result.2 ≤ budget) :
+    (simulateQ impl (run selected computation budget)).map (Option.map Prod.fst) =
+      (simulateQ impl computation).map some := by
+  rw [run_eq_some_counted selected impl computation budget hbound, PMF.map_comp]
+  change (simulateQ impl (counted selected computation)).map (some ∘ Prod.fst) = _
+  rw [← PMF.map_comp]
+  apply congrArg (PMF.map some)
+  rw [← PMF.monad_map_eq_map, ← simulateQ_map, counted_forget]
+
+theorem run_recover_count (impl : QueryImpl spec PMF) (computation : OracleComp spec Result) (budget : Nat)
+    (hbound : ∀ result ∈ (simulateQ impl (counted selected computation)).support, result.2 ≤ budget) :
+    (simulateQ impl (run selected computation budget)).map (Option.map (fun result => (result.1, budget - result.2))) =
+      (simulateQ impl (counted selected computation)).map some := by
+  rw [run_eq_some_counted selected impl computation budget hbound, PMF.map_comp]
+  apply map_eq_on_support
+  intro result hresult
+  simp only [Function.comp_apply, Option.map_some]
+  congr 2
+  exact Nat.sub_sub_self (hbound result hresult)
+
+end SphincsSecurity.QueryCap
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/QueryCapState.lean b/formal/sphincs/SphincsSecurity/Proof/Base/QueryCapState.lean
new file mode 100644
index 000000000..2dbbc9a89
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/QueryCapState.lean
@@ -0,0 +1,56 @@
+import SphincsSecurity.Proof.Base.QueryCapErasure
+namespace SphincsSecurity.QueryCap
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {Index Memory Result : Type} {spec : OracleSpec Index}
+  (selected : Index → Prop) [DecidablePred selected]
+
+theorem run_state_eq_counted (impl : QueryImpl spec (StateT Memory PMF))
+    (computation : OracleComp spec Result) (budget : Nat) (memory : Memory) :
+    ((simulateQ impl (run selected computation budget)).run memory).map Prod.fst =
+      ((simulateQ impl (counted selected computation)).run memory).map (fun result => finish budget result.1) := by
+  induction computation using OracleComp.inductionOn generalizing budget memory with
+  | pure result =>
+      simp only [run_pure, counted_pure, simulateQ_pure, StateT.run_pure, PMF.monad_pure_eq_pure,
+        PMF.map, PMF.pure_bind, Function.comp_def, finish, Nat.zero_le, if_true, Nat.sub_zero]
+  | query_bind input next ih =>
+      rw [run_query_bind, counted_query_bind]
+      by_cases hs : selected input
+      · rw [if_pos hs]
+        cases budget with
+        | zero =>
+            simp only [simulateQ_pure, simulateQ_bind, simulateQ_spec_query, StateT.run_pure, StateT.run_bind,
+              PMF.monad_bind_eq_bind, PMF.monad_pure_eq_pure, PMF.map, PMF.bind_bind, PMF.pure_bind,
+              Function.comp_def, finish, if_pos hs, Nat.add_comm 1, Nat.add_one_le_iff, Nat.not_lt_zero, if_false, PMF.bind_const]
+        | succ budget =>
+            simp only [simulateQ_bind, simulateQ_spec_query, StateT.run_bind, simulateQ_pure, StateT.run_pure,
+              PMF.monad_bind_eq_bind, PMF.monad_pure_eq_pure, PMF.map_bind]
+            apply congrArg ((impl input).run memory).bind
+            funext middle
+            rw [ih middle.1 budget middle.2]
+            simp only [PMF.map, PMF.pure_bind, Function.comp_def, finish, if_pos hs,
+              Nat.add_comm 1, Nat.add_le_add_iff_right, Nat.add_sub_add_right]
+      · simp only [if_neg hs, simulateQ_bind, simulateQ_spec_query, StateT.run_bind, simulateQ_pure, StateT.run_pure,
+          PMF.monad_bind_eq_bind, PMF.monad_pure_eq_pure, PMF.map_bind]
+        apply congrArg ((impl input).run memory).bind
+        funext middle
+        rw [ih middle.1 budget middle.2]
+        simp only [PMF.map, PMF.pure_bind, Function.comp_def, finish, Nat.zero_add]
+
+theorem counted_state_le_of_cap_valid (impl : QueryImpl spec (StateT Memory PMF))
+    (computation : OracleComp spec Result) (budget : Nat) (memory : Memory)
+    (hvalid : ∀ result ∈ ((simulateQ impl (run selected computation budget)).run memory).support, result.1 ≠ none)
+    (result : (Result × Nat) × Memory)
+    (hresult : result ∈ ((simulateQ impl (counted selected computation)).run memory).support) : result.1.2 ≤ budget := by
+  by_contra hlarge
+  have hmap : finish budget result.1 ∈
+      (((simulateQ impl (counted selected computation)).run memory).map (fun result => finish budget result.1)).support := by
+    rw [PMF.mem_support_map_iff]
+    exact ⟨result, hresult, rfl⟩
+  rw [← run_state_eq_counted selected impl computation budget memory, PMF.mem_support_map_iff] at hmap
+  obtain ⟨capped, hcapped, heq⟩ := hmap
+  exact hvalid capped hcapped (heq.trans (if_neg hlarge))
+
+end SphincsSecurity.QueryCap
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/QueryPause.lean b/formal/sphincs/SphincsSecurity/Proof/Base/QueryPause.lean
new file mode 100644
index 000000000..28c12f458
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/QueryPause.lean
@@ -0,0 +1,44 @@
+import SphincsSecurity.Proof.Base.QueryCapAccounting
+namespace SphincsSecurity.QueryPause
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {Index Memory Result : Type} {spec : OracleSpec Index}
+  (stop : Memory → Prop) [DecidablePred stop]
+  (step : (input : spec.Domain) → spec.Range input → Memory → Memory)
+
+noncomputable def run (computation : OracleComp spec Result) : Memory → OracleComp spec (Memory × OracleComp spec Result) :=
+  OracleComp.construct (fun result memory => pure (memory, pure result))
+    (fun input original next memory =>
+      if stop memory then pure (memory, liftM (spec.query input) >>= original)
+      else liftM (spec.query input) >>= fun answer => next answer (step input answer memory)) computation
+
+theorem run_pure (result : Result) (memory : Memory) :
+    run stop step (pure result : OracleComp spec Result) memory = pure (memory, pure result) := rfl
+
+theorem run_query_bind (input : spec.Domain) (next : spec.Range input → OracleComp spec Result) (memory : Memory) :
+    run stop step (liftM (spec.query input) >>= next) memory =
+      if stop memory then pure (memory, liftM (spec.query input) >>= next)
+      else liftM (spec.query input) >>= fun answer => run stop step (next answer) (step input answer memory) := rfl
+
+theorem resume (computation : OracleComp spec Result) (memory : Memory) :
+    (run stop step computation memory >>= fun paused => paused.2) = computation := by
+  induction computation using OracleComp.inductionOn generalizing memory with
+  | pure result => simp only [run_pure, pure_bind]
+  | query_bind input next ih =>
+      rw [run_query_bind]
+      by_cases hs : stop memory
+      · simp only [if_pos hs, pure_bind]
+      · simp only [if_neg hs, bind_assoc, ih]
+
+variable (selected : Index → Prop) [DecidablePred selected]
+
+theorem counted_resume (computation : OracleComp spec Result) (memory : Memory) :
+    (do
+      let paused ← QueryCap.counted selected (run stop step computation memory)
+      let result ← QueryCap.counted selected paused.1.2
+      pure (result.1, paused.2 + result.2)) = QueryCap.counted selected computation := by
+  rw [← QueryCap.counted_bind, resume]
+
+end SphincsSecurity.QueryPause
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/QueryPauseInvariant.lean b/formal/sphincs/SphincsSecurity/Proof/Base/QueryPauseInvariant.lean
new file mode 100644
index 000000000..e0bb2cd82
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/QueryPauseInvariant.lean
@@ -0,0 +1,74 @@
+import SphincsSecurity.Proof.Base.QueryPause
+namespace SphincsSecurity.QueryPause
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {Index Memory Result : Type} {spec : OracleSpec Index}
+  (stop : Memory → Prop) [DecidablePred stop]
+  (step : (input : spec.Domain) → spec.Range input → Memory → Memory)
+
+theorem run_invariant (invariant : Memory → Prop)
+    (hstep : ∀ memory, invariant memory → ¬stop memory → ∀ input answer, invariant (step input answer memory))
+    (computation : OracleComp spec Result) (memory : Memory) (hinitial : invariant memory)
+    (result : Memory × OracleComp spec Result) (hresult : result ∈ support (run stop step computation memory)) :
+    invariant result.1 := by
+  induction computation using OracleComp.inductionOn generalizing memory result with
+  | pure value =>
+      rw [run_pure, mem_support_pure_iff] at hresult
+      subst result
+      exact hinitial
+  | query_bind input next ih =>
+      rw [run_query_bind] at hresult
+      by_cases hs : stop memory
+      · rw [if_pos hs, mem_support_pure_iff] at hresult
+        subst result
+        exact hinitial
+      · rw [if_neg hs, mem_support_bind_iff] at hresult
+        obtain ⟨answer, _, hresult⟩ := hresult
+        exact ih answer (step input answer memory) (hstep memory hinitial hs input answer) result hresult
+
+theorem run_stopped_or_finished (computation : OracleComp spec Result) (memory : Memory)
+    (result : Memory × OracleComp spec Result) (hresult : result ∈ support (run stop step computation memory)) :
+    stop result.1 ∨ ∃ value, result.2 = pure value := by
+  induction computation using OracleComp.inductionOn generalizing memory result with
+  | pure value =>
+      rw [run_pure, mem_support_pure_iff] at hresult
+      subst result
+      exact Or.inr ⟨value, rfl⟩
+  | query_bind input next ih =>
+      rw [run_query_bind] at hresult
+      by_cases hs : stop memory
+      · rw [if_pos hs, mem_support_pure_iff] at hresult
+        subst result
+        exact Or.inl hs
+      · rw [if_neg hs, mem_support_bind_iff] at hresult
+        obtain ⟨answer, _, hresult⟩ := hresult
+        exact ih answer (step input answer memory) result hresult
+
+theorem run_simulation_invariant {State : Type} (impl : QueryImpl spec (StateT State PMF))
+    (invariant : Memory → State → Prop)
+    (hstep : ∀ memory state, invariant memory state → ¬stop memory → ∀ input,
+      ∀ result ∈ ((impl input).run state).support, invariant (step input result.1 memory) result.2)
+    (computation : OracleComp spec Result) (memory : Memory) (state : State) (hinitial : invariant memory state)
+    (result : (Memory × OracleComp spec Result) × State)
+    (hresult : result ∈ ((simulateQ impl (run stop step computation memory)).run state).support) :
+    invariant result.1.1 result.2 := by
+  induction computation using OracleComp.inductionOn generalizing memory state result with
+  | pure value =>
+      simp only [run_pure, simulateQ_pure, StateT.run_pure, PMF.monad_pure_eq_pure, PMF.mem_support_pure_iff] at hresult
+      subst result
+      exact hinitial
+  | query_bind input next ih =>
+      rw [run_query_bind] at hresult
+      by_cases hs : stop memory
+      · simp only [if_pos hs, simulateQ_pure, StateT.run_pure, PMF.monad_pure_eq_pure, PMF.mem_support_pure_iff] at hresult
+        subst result
+        exact hinitial
+      · simp only [if_neg hs, simulateQ_bind, simulateQ_spec_query, StateT.run_bind,
+          PMF.monad_bind_eq_bind, PMF.mem_support_bind_iff] at hresult
+        obtain ⟨middle, hmiddle, hresult⟩ := hresult
+        exact ih middle.1 (step input middle.1 memory) middle.2
+          (hstep memory state hinitial hs input middle hmiddle) result hresult
+
+end SphincsSecurity.QueryPause
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/QueryPauseTrace.lean b/formal/sphincs/SphincsSecurity/Proof/Base/QueryPauseTrace.lean
new file mode 100644
index 000000000..a45e75b9d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/QueryPauseTrace.lean
@@ -0,0 +1,56 @@
+import SphincsSecurity.Proof.Base.QueryPauseInvariant
+namespace SphincsSecurity.QueryPause
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {Index Trace Result : Type} {spec : OracleSpec Index} [Monoid Trace]
+  (observation : (input : spec.Domain) → spec.Range input → Trace)
+
+noncomputable def traced (computation : OracleComp spec Result) : OracleComp spec (Result × Trace) :=
+  (simulateQ ((QueryImpl.id' spec).withTrace observation) computation).run
+
+theorem traced_pure (result : Result) : traced observation (pure result : OracleComp spec Result) = pure (result, 1) := by
+  simp only [traced, simulateQ_pure, WriterT.run_pure]
+
+theorem traced_forget (computation : OracleComp spec Result) : Prod.fst <$> traced observation computation = computation := by
+  rw [traced, QueryImpl.fst_map_run_withTrace, simulateQ_id']
+
+theorem traced_query_bind (input : spec.Domain) (next : spec.Range input → OracleComp spec Result) :
+    traced observation (liftM (spec.query input) >>= next) =
+      liftM (spec.query input) >>= fun answer => (fun tail => (tail.1, observation input answer * tail.2)) <$> traced observation (next answer) := by
+  simp only [traced, simulateQ_bind, simulateQ_spec_query, QueryImpl.withTrace_apply,
+    WriterT.run_bind, WriterT.run_tell, QueryImpl.id'_apply, WriterT.run_monadLift, bind_map_left, bind_assoc, pure_bind, one_mul, Functor.map_map]
+
+theorem traced_counted (selected : Index → Prop) [DecidablePred selected] (cost : Trace → Nat)
+    (hzero : cost 1 = 0)
+    (hstep : ∀ input answer trace, cost (observation input answer * trace) = (if selected input then 1 else 0) + cost trace)
+    (computation : OracleComp spec Result) :
+    (fun result => (result.1, cost result.2)) <$> traced observation computation = QueryCap.counted selected computation := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => simp only [traced_pure, QueryCap.counted_pure, map_pure, hzero]
+  | query_bind input next ih =>
+      simp only [traced_query_bind, QueryCap.counted_query_bind, map_bind, Functor.map_map, hstep]
+      congr 1
+      funext answer
+      rw [← ih answer]
+      simp only [bind_pure_comp, Functor.map_map]
+
+theorem trace_resume (stop : Trace → Prop) [DecidablePred stop]
+    (computation : OracleComp spec Result) (history : Trace) :
+    (do
+      let paused ← run stop (fun input answer memory => memory * observation input answer) computation history
+      let tail ← traced observation paused.2
+      pure (tail.1, paused.1 * tail.2)) =
+        (fun result => (result.1, history * result.2)) <$> traced observation computation := by
+  induction computation using OracleComp.inductionOn generalizing history with
+  | pure result => simp only [run_pure, traced_pure, pure_bind, map_pure, mul_one]
+  | query_bind input next ih =>
+      rw [run_query_bind]
+      by_cases hs : stop history
+      · simp only [if_pos hs, pure_bind, bind_pure_comp]
+      · simp only [if_neg hs, bind_assoc, traced_query_bind, map_bind, Functor.map_map, ← mul_assoc]
+        exact congrArg (fun continuation => liftM (spec.query input) >>= continuation)
+          (funext fun answer => ih answer (history * observation input answer))
+
+end SphincsSecurity.QueryPause
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/QueryTraceInvariant.lean b/formal/sphincs/SphincsSecurity/Proof/Base/QueryTraceInvariant.lean
new file mode 100644
index 000000000..46f23e85a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/QueryTraceInvariant.lean
@@ -0,0 +1,52 @@
+import SphincsSecurity.Proof.Base.QueryPauseTrace
+import SphincsSecurity.Proof.Reference.QueryAllocation
+namespace SphincsSecurity.QueryPause
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {Index Trace Result : Type} {spec : OracleSpec Index} [Monoid Trace]
+  (observation : (input : spec.Domain) → spec.Range input → Trace)
+
+theorem traced_simulation_invariant {State : Type} (impl : QueryImpl spec (StateT State PMF))
+    (invariant : Trace → State → Prop)
+    (hstep : ∀ history state, invariant history state → ∀ input,
+      ∀ result ∈ ((impl input).run state).support, invariant (history * observation input result.1) result.2)
+    (computation : OracleComp spec Result) (history : Trace) (state : State) (hinitial : invariant history state)
+    (result : (Result × Trace) × State)
+    (hresult : result ∈ ((simulateQ impl (traced observation computation)).run state).support) :
+    invariant (history * result.1.2) result.2 := by
+  induction computation using OracleComp.inductionOn generalizing history state result with
+  | pure value =>
+      simp only [traced_pure, simulateQ_pure, StateT.run_pure, PMF.monad_pure_eq_pure, PMF.mem_support_pure_iff] at hresult
+      subst result
+      simpa only [mul_one] using hinitial
+  | query_bind input next ih =>
+      simp only [traced_query_bind, simulateQ_bind, simulateQ_map, simulateQ_spec_query, StateT.run_bind, StateT.run_map,
+        PMF.monad_bind_eq_bind, PMF.monad_map_eq_map, PMF.mem_support_bind_iff, PMF.mem_support_map_iff] at hresult
+      obtain ⟨middle, hmiddle, tail, htail, rfl⟩ := hresult
+      simpa only [mul_assoc] using ih middle.1 (history * observation input middle.1) middle.2
+        (hstep history state hinitial input middle hmiddle) tail htail
+
+theorem traced_counted_forget (selected : Index → Prop) [DecidablePred selected] (computation : OracleComp spec Result) :
+    (fun result => (result.1.1, result.2)) <$> QueryCap.counted selected (traced observation computation) =
+      QueryCap.counted selected computation := by
+  rw [← QueryCap.counted_map, traced_forget]
+
+theorem traced_counted_le (selected : Index → Prop) [DecidablePred selected] (cost : Trace → Nat)
+    (hcost : ∀ first second, cost (first * second) = cost first + cost second)
+    (hstep : ∀ input answer, (if selected input then 1 else 0) ≤ cost (observation input answer))
+    (computation : OracleComp spec Result) (result : (Result × Trace) × Nat)
+    (hresult : result ∈ support (QueryCap.counted selected (traced observation computation))) : result.2 ≤ cost result.1.2 := by
+  apply QueryCap.counted_writer_simulate_le selected cost hcost ((QueryImpl.id' spec).withTrace observation) _ computation result hresult
+  intro input output houtput
+  have hquery : (((QueryImpl.id' spec).withTrace observation) input).run =
+      (fun answer => (answer, observation input answer)) <$> (liftM (spec.query input) : OracleComp spec _) := by
+    simp [QueryImpl.withTrace_apply, WriterT.run_bind, WriterT.run_tell]
+  rw [hquery, QueryCap.counted_map, support_map] at houtput
+  obtain ⟨counted, hcounted, rfl⟩ := houtput
+  rw [QueryCap.counted_query, support_map] at hcounted
+  obtain ⟨answer, _, rfl⟩ := hcounted
+  exact hstep input answer
+
+end SphincsSecurity.QueryPause
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/QueryTracePotential.lean b/formal/sphincs/SphincsSecurity/Proof/Base/QueryTracePotential.lean
new file mode 100644
index 000000000..f45f11264
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/QueryTracePotential.lean
@@ -0,0 +1,105 @@
+import SphincsSecurity.Proof.Base.QueryTraceInvariant
+import SphincsSecurity.Proof.Residual.RetainedObservation
+namespace SphincsSecurity.QueryPause
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {Index Trace Result State : Type} {spec : OracleSpec Index} [Monoid Trace]
+  (observation : (input : spec.Domain) → spec.Range input → Trace) (impl : QueryImpl spec (StateT State SPMF))
+
+theorem traced_spmf_query_bind (input : spec.Domain) (next : spec.Range input → OracleComp spec Result) (state : State) :
+    (simulateQ impl (traced observation (liftM (spec.query input) >>= next))).run state =
+      ((impl input).run state >>= fun middle =>
+        (fun result => ((result.1.1, observation input middle.1 * result.1.2), result.2)) <$>
+          (simulateQ impl (traced observation (next middle.1))).run middle.2) := by
+  simp only [traced_query_bind, simulateQ_bind, simulateQ_map, simulateQ_spec_query, StateT.run_bind, StateT.run_map]
+
+theorem traced_spmf_history_potential_le (invariant : Trace → State → Prop)
+    (hpreserve : ∀ history state, invariant history state → ∀ input result,
+      (impl input).run state result ≠ 0 → invariant (history * observation input result.1) result.2)
+    (hmass : ∀ (computation : OracleComp spec Result) history state, invariant history state →
+      Pr[⊥ | (simulateQ impl (traced observation computation)).run state] = 0)
+    (potential : Trace → State → ENNReal) (rate : ENNReal) (cost : Trace → Trace → Nat) (charge : Trace → spec.Domain → Nat)
+    (hzero : ∀ history, cost history 1 = 0)
+    (hcost : ∀ history input answer tail, cost history (observation input answer * tail) =
+      charge history input + cost (history * observation input answer) tail)
+    (hstep : ∀ history state, invariant history state → ∀ input,
+      (∑' result, Pr[= result | (impl input).run state] * potential (history * observation input result.1) result.2) ≤
+        potential history state + rate * (charge history input : ENNReal))
+    (computation : OracleComp spec Result) (history : Trace) (state : State) (hi : invariant history state) :
+    (∑' result, Pr[= result | (simulateQ impl (traced observation computation)).run state] *
+      potential (history * result.1.2) result.2) ≤ potential history state + rate *
+        ∑' result, Pr[= result | (simulateQ impl (traced observation computation)).run state] * (cost history result.1.2 : ENNReal) := by
+  induction computation using OracleComp.inductionOn generalizing history state with
+  | pure value =>
+      simp only [traced_pure, simulateQ_pure, StateT.run_pure, tsum_probOutput_pure_mul,
+        mul_one, hzero, Nat.cast_zero, mul_zero, add_zero, le_refl]
+  | query_bind input next ih =>
+      simp only [traced_spmf_query_bind, tsum_probOutput_bind_mul, tsum_probOutput_map_mul, ← mul_assoc, hcost, Nat.cast_add]
+      have hconstant : (∑' middle, Pr[= middle | (impl input).run state] *
+          ∑' result, Pr[= result | (simulateQ impl (traced observation (next middle.1))).run middle.2] *
+            ((charge history input : ENNReal) + (cost (history * observation input middle.1) result.1.2 : ENNReal))) =
+          (charge history input : ENNReal) * (∑' middle, Pr[= middle | (impl input).run state]) +
+            ∑' middle, Pr[= middle | (impl input).run state] *
+              ∑' result, Pr[= result | (simulateQ impl (traced observation (next middle.1))).run middle.2] * (cost (history * observation input middle.1) result.1.2 : ENNReal) := by
+        rw [← ENNReal.tsum_mul_left, ← ENNReal.tsum_add]
+        apply tsum_congr
+        intro middle
+        by_cases hm : (impl input).run state middle = 0
+        · simp only [SPMF.probOutput_eq_apply, hm, zero_mul, mul_zero, zero_add]
+        · have hi' := hpreserve history state hi input middle hm
+          rw [show (∑' result, Pr[= result | (simulateQ impl (traced observation (next middle.1))).run middle.2] *
+              ((charge history input : ENNReal) + (cost (history * observation input middle.1) result.1.2 : ENNReal))) =
+              (charge history input : ENNReal) + ∑' result,
+                Pr[= result | (simulateQ impl (traced observation (next middle.1))).run middle.2] * (cost (history * observation input middle.1) result.1.2 : ENNReal) by
+            simp only [mul_add, ENNReal.tsum_add, ENNReal.tsum_mul_right,
+              tsum_probOutput_eq_one' (hmass (next middle.1) _ _ hi'), one_mul]]
+          rw [mul_add, mul_comm _ (charge history input : ENNReal)]
+      calc
+        _ ≤ ∑' middle, Pr[= middle | (impl input).run state] *
+            (potential (history * observation input middle.1) middle.2 + rate *
+              ∑' result, Pr[= result | (simulateQ impl (traced observation (next middle.1))).run middle.2] * (cost (history * observation input middle.1) result.1.2 : ENNReal)) := by
+          apply ENNReal.tsum_le_tsum
+          intro middle
+          by_cases hm : (impl input).run state middle = 0
+          · simp only [SPMF.probOutput_eq_apply, hm, zero_mul, le_refl]
+          · exact mul_le_mul' le_rfl (ih middle.1 _ _ (hpreserve history state hi input middle hm))
+        _ = (∑' middle, Pr[= middle | (impl input).run state] *
+            potential (history * observation input middle.1) middle.2) + rate *
+            ∑' middle, Pr[= middle | (impl input).run state] *
+              ∑' result, Pr[= result | (simulateQ impl (traced observation (next middle.1))).run middle.2] * (cost (history * observation input middle.1) result.1.2 : ENNReal) := by
+          simp only [mul_add, ENNReal.tsum_add, mul_left_comm _ rate, ENNReal.tsum_mul_left]
+        _ ≤ _ := by
+          have hqueryMass : (∑' middle, Pr[= middle | (impl input).run state]) = 1 := by
+            have hfull : (∑' result, Pr[= result |
+                (simulateQ impl (traced observation (liftM (spec.query input) >>= next))).run state] * (1 : ENNReal)) = 1 := by
+              simpa only [mul_one] using tsum_probOutput_eq_one' (hmass (liftM (spec.query input) >>= next) history state hi)
+            rw [traced_spmf_query_bind, tsum_probOutput_bind_mul] at hfull
+            simp only [mul_one] at hfull
+            exact le_antisymm tsum_probOutput_le_one (by
+              rw [← hfull]
+              apply ENNReal.tsum_le_tsum
+              intro middle
+              exact mul_le_of_le_one_right zero_le tsum_probOutput_le_one)
+          rw [hconstant, hqueryMass, mul_one, mul_add, ← add_assoc]
+          exact add_le_add (hstep history state hi input) le_rfl
+
+theorem traced_spmf_potential_le (invariant : Trace → State → Prop)
+    (hpreserve : ∀ history state, invariant history state → ∀ input result,
+      (impl input).run state result ≠ 0 → invariant (history * observation input result.1) result.2)
+    (hmass : ∀ (computation : OracleComp spec Result) history state, invariant history state →
+      Pr[⊥ | (simulateQ impl (traced observation computation)).run state] = 0)
+    (potential : Trace → State → ENNReal) (rate : ENNReal) (cost : Trace → Nat) (charge : spec.Domain → Nat)
+    (hzero : cost 1 = 0) (hcost : ∀ input answer tail, cost (observation input answer * tail) = charge input + cost tail)
+    (hstep : ∀ history state, invariant history state → ∀ input,
+      (∑' result, Pr[= result | (impl input).run state] * potential (history * observation input result.1) result.2) ≤
+        potential history state + rate * (charge input : ENNReal))
+    (computation : OracleComp spec Result) (history : Trace) (state : State) (hi : invariant history state) :
+    (∑' result, Pr[= result | (simulateQ impl (traced observation computation)).run state] *
+      potential (history * result.1.2) result.2) ≤ potential history state + rate *
+        ∑' result, Pr[= result | (simulateQ impl (traced observation computation)).run state] * (cost result.1.2 : ENNReal) := by
+  exact traced_spmf_history_potential_le observation impl invariant hpreserve hmass potential rate
+    (fun _ => cost) (fun _ => charge) (fun _ => hzero) (fun _ => hcost) hstep computation history state hi
+
+end SphincsSecurity.QueryPause
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/RomQueryCharge.lean b/formal/sphincs/SphincsSecurity/Proof/Base/RomQueryCharge.lean
new file mode 100644
index 000000000..711d0040f
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/RomQueryCharge.lean
@@ -0,0 +1,147 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CacheSize
+import SphincsSecurity.Proof.Scheme.Charge
+namespace SphincsSecurity
+
+open OracleComp OracleSpec ENNReal
+
+def hashQueryCharge (charge : QueryCache HashSpec → HashInput → ℝ≥0∞)
+    (cache : QueryCache HashSpec) : OracleWorld.Domain → ℝ≥0∞ :=
+  Sum.elim (fun _ => 0) (charge cache)
+
+noncomputable def expectedQueryCharge {α : Type}
+    (charge : QueryCache HashSpec → HashInput → ℝ≥0∞)
+    (computation : OracleComp OracleWorld α) : QueryCache HashSpec → ℝ≥0∞ :=
+  OracleComp.construct (fun _ _ => 0)
+    (fun query _ next cache =>
+      hashQueryCharge charge cache query +
+        ∑' result, Pr[= result | (romImpl query).run cache] * next result.1 result.2)
+    computation
+
+@[simp] theorem expectedQueryCharge_pure {α : Type}
+    (charge : QueryCache HashSpec → HashInput → ℝ≥0∞)
+    (value : α) (cache : QueryCache HashSpec) :
+    expectedQueryCharge charge (pure value) cache = 0 := rfl
+
+theorem expectedQueryCharge_query_bind {α : Type}
+    (charge : QueryCache HashSpec → HashInput → ℝ≥0∞)
+    (query : OracleWorld.Domain)
+    (next : OracleWorld.Range query → OracleComp OracleWorld α)
+    (cache : QueryCache HashSpec) :
+    expectedQueryCharge charge (OracleSpec.query query >>= next) cache =
+      hashQueryCharge charge cache query +
+        ∑' result, Pr[= result | (romImpl query).run cache] *
+          expectedQueryCharge charge (next result.1) result.2 := by
+  cases query <;> rfl
+
+theorem romImpl_query_mass (query : OracleWorld.Domain) (cache : QueryCache HashSpec) :
+    (∑' result, Pr[= result | (romImpl query).run cache]) = 1 := by
+  cases query with
+  | inl input =>
+      simp [romImpl, unifFwdImpl, QueryImpl.liftTarget, HasQuery.toQueryImpl,
+        StateT.run_monadLift]
+      rw [ENNReal.tsum_prod']
+      simp only [tsum_ite_eq, tsum_fintype, Finset.sum_const, Finset.card_univ, nsmul_eq_mul]
+      simp [Fintype.card_fin]
+      exact ENNReal.mul_inv_cancel (by positivity) (by finiteness)
+  | inr input =>
+      change (∑' result, Pr[= result | (randomOracle input).run cache]) = 1
+      by_cases hfresh : cache input = none
+      · rw [randomOracle, QueryImpl.withCaching_run_none _ hfresh]
+        simp [uniformSampleImpl]
+      · obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp hfresh
+        rw [randomOracle, QueryImpl.withCaching_run_some _ hanswer]
+        simp
+
+theorem finite_of_mem_support_romImpl {query : OracleWorld.Domain}
+    {cache : QueryCache HashSpec} (hfinite : Finite cache)
+    {result : OracleWorld.Range query × QueryCache HashSpec}
+    (hresult : result ∈ support ((romImpl query).run cache)) : Finite result.2 := by
+  cases query with
+  | inl input =>
+      apply Finite.of_enncard_le (q := {input | cache input ≠ none}.ncard)
+      rw [romImpl_uniform_query_enncard_eq input cache result hresult,
+        hfinite.cachedInputs_ncard_toENNReal_eq_enncard]
+  | inr input =>
+      apply Finite.of_enncard_le (q := {input | cache input ≠ none}.ncard + 1)
+      push_cast
+      rw [hfinite.cachedInputs_ncard_toENNReal_eq_enncard]
+      exact romImpl_hash_query_enncard_le input cache result hresult
+
+theorem expected_potential_simulateQ_le_queryCharge {α : Type}
+    (potential : QueryCache HashSpec → ℝ≥0∞)
+    (charge : QueryCache HashSpec → HashInput → ℝ≥0∞)
+    (hstep : ∀ (query : OracleWorld.Domain) (cache : QueryCache HashSpec), Finite cache →
+      (∑' result, Pr[= result | (romImpl query).run cache] * potential result.2) ≤
+        potential cache + hashQueryCharge charge cache query)
+    (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec)
+    (hfinite : Finite cache) :
+    (∑' result, Pr[= result | (simulateQ romImpl computation).run cache] * potential result.2) ≤
+      potential cache + expectedQueryCharge charge computation cache := by
+  induction computation using OracleComp.inductionOn generalizing cache with
+  | pure value => simp [simulateQ_pure]
+  | query_bind query next ih =>
+      rw [simulateQ_bind, simulateQ_spec_query, StateT.run_bind, tsum_probOutput_bind_mul,
+        expectedQueryCharge_query_bind]
+      calc
+        _ ≤ ∑' result, Pr[= result | (romImpl query).run cache] *
+            (potential result.2 + expectedQueryCharge charge (next result.1) result.2) := by
+          apply ENNReal.tsum_le_tsum
+          intro result
+          by_cases hresult : result ∈ support ((romImpl query).run cache)
+          · exact mul_le_mul' le_rfl
+              (ih result.1 result.2 (finite_of_mem_support_romImpl hfinite hresult))
+          · rw [probOutput_eq_zero_of_not_mem_support hresult, zero_mul, zero_mul]
+        _ = (∑' result, Pr[= result | (romImpl query).run cache] * potential result.2) +
+            ∑' result, Pr[= result | (romImpl query).run cache] *
+              expectedQueryCharge charge (next result.1) result.2 := by
+          simp_rw [mul_add, ENNReal.tsum_add]
+        _ ≤ (potential cache +
+              hashQueryCharge charge cache query) +
+            ∑' result, Pr[= result | (romImpl query).run cache] *
+              expectedQueryCharge charge (next result.1) result.2 :=
+          add_le_add (hstep query cache hfinite) le_rfl
+        _ = _ := by rw [add_assoc]
+
+theorem expectedQueryCharge_mul {α : Type}
+    (charge : QueryCache HashSpec → HashInput → ℝ≥0∞) (factor : ℝ≥0∞)
+    (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec) :
+    expectedQueryCharge (fun cache input => charge cache input * factor) computation cache =
+      expectedQueryCharge charge computation cache * factor := by
+  induction computation using OracleComp.inductionOn generalizing cache with
+  | pure value => simp
+  | query_bind query next ih =>
+      simp only [expectedQueryCharge_query_bind, ih]
+      simp_rw [← mul_assoc, ENNReal.tsum_mul_right]
+      cases query <;> simp only [hashQueryCharge, Sum.elim_inl, Sum.elim_inr] <;> ring
+
+theorem expected_potential_romImpl_le_charge
+    (potential : QueryCache HashSpec → ℝ≥0∞)
+    (charge : QueryCache HashSpec → HashInput → ℝ≥0∞)
+    (hfresh : ∀ cache : QueryCache HashSpec, Finite cache → ∀ input : HashInput,
+      cache input = none →
+      (∑' answer : HashOutput, Pr[= answer | ($ᵗ HashOutput : ProbComp HashOutput)] *
+        potential (cache.cacheQuery input answer)) ≤ potential cache + charge cache input)
+    (query : OracleWorld.Domain) (cache : QueryCache HashSpec) (hfinite : Finite cache) :
+    (∑' result, Pr[= result | (romImpl query).run cache] * potential result.2) ≤
+      potential cache + hashQueryCharge charge cache query := by
+  cases query with
+  | inl input =>
+      simp [romImpl, unifFwdImpl, QueryImpl.liftTarget, HasQuery.toQueryImpl,
+        StateT.run_monadLift, hashQueryCharge]
+      rw [ENNReal.tsum_prod']
+      simp only [tsum_ite_eq, tsum_fintype, Finset.sum_const, Finset.card_univ, nsmul_eq_mul]
+      simp [Fintype.card_fin]
+      rw [← mul_assoc, ENNReal.mul_inv_cancel (by positivity) (by finiteness), one_mul]
+  | inr input =>
+      change (∑' result, Pr[= result | (randomOracle input).run cache] * potential result.2) ≤
+        potential cache + charge cache input
+      by_cases huncached : cache input = none
+      · rw [randomOracle, QueryImpl.withCaching_run_none _ huncached,
+          tsum_probOutput_map_mul]
+        exact hfresh cache hfinite input huncached
+      · obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp huncached
+        rw [randomOracle, QueryImpl.withCaching_run_some _ hanswer]
+        simp
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/RomQueryChargeBind.lean b/formal/sphincs/SphincsSecurity/Proof/Base/RomQueryChargeBind.lean
new file mode 100644
index 000000000..310f64e3e
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/RomQueryChargeBind.lean
@@ -0,0 +1,26 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Base.RomQueryCharge
+namespace SphincsSecurity
+
+open OracleComp OracleSpec ENNReal
+
+theorem expectedQueryCharge_bind
+    (charge : QueryCache HashSpec → HashInput → ℝ≥0∞)
+    (computation : OracleComp OracleWorld α) (next : α → OracleComp OracleWorld β)
+    (cache : QueryCache HashSpec) :
+    expectedQueryCharge charge (computation >>= next) cache =
+      expectedQueryCharge charge computation cache +
+        ∑' result, Pr[= result | (simulateQ romImpl computation).run cache] *
+          expectedQueryCharge charge (next result.1) result.2 := by
+  induction computation using OracleComp.inductionOn generalizing cache with
+  | pure value =>
+      simp only [pure_bind, expectedQueryCharge_pure, simulateQ_pure, StateT.run_pure,
+        tsum_probOutput_pure_mul, zero_add]
+  | query_bind query continuation ih =>
+      rw [bind_assoc, expectedQueryCharge_query_bind, expectedQueryCharge_query_bind,
+        simulateQ_query_bind, StateT.run_bind, tsum_probOutput_bind_mul]
+      simp_rw [ih, mul_add, ENNReal.tsum_add, ← ENNReal.tsum_mul_left]
+      rw [add_assoc]
+      rfl
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/StirlingMomentBounds.lean b/formal/sphincs/SphincsSecurity/Proof/Base/StirlingMomentBounds.lean
new file mode 100644
index 000000000..76740d86b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/StirlingMomentBounds.lean
@@ -0,0 +1,40 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.UniformProposalMixedMoments
+namespace SphincsSecurity.Concrete
+
+open ENNReal
+
+theorem stirlingPowerMoment_ne_top (rate : ENNReal) (hrate : rate ≠ ⊤) (degree : Nat) :
+    stirlingPowerMoment rate degree ≠ ⊤ := by
+  unfold stirlingPowerMoment
+  apply ENNReal.sum_ne_top.mpr
+  intro order _
+  exact ENNReal.mul_ne_top (by finiteness) (ENNReal.pow_ne_top hrate)
+
+set_option maxHeartbeats 5000000 in
+theorem stirlingPowerMoment_full_mean_le :
+    (2 ^ 26 : ENNReal) * (2 ^ 48 : ENNReal)⁻¹ * stirlingPowerMoment (19 / 50) 14 ≤ 1 / 5 := by
+  have hm := stirlingPowerMoment_ne_top (19 / 50) (by finiteness) 14
+  apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp
+  simp only [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_pow, ENNReal.toReal_div,
+    ENNReal.toReal_ofNat, ENNReal.toReal_one]
+  unfold stirlingPowerMoment
+  rw [ENNReal.toReal_sum (fun order _ => by finiteness)]
+  simp only [ENNReal.toReal_mul, ENNReal.toReal_pow, ENNReal.toReal_div, ENNReal.toReal_ofNat,
+    ENNReal.toReal_natCast]
+  norm_num [Finset.sum_range_succ, Nat.stirlingSecond]
+
+set_option maxHeartbeats 5000000 in
+theorem stirlingPowerMoment_full_variance_le :
+    (2 ^ 26 : ENNReal) * (2 ^ 96 : ENNReal)⁻¹ * stirlingPowerMoment (19 / 50) 28 ≤ 13 / 25000 := by
+  have hm := stirlingPowerMoment_ne_top (19 / 50) (by finiteness) 28
+  apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp
+  simp only [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_pow, ENNReal.toReal_div,
+    ENNReal.toReal_ofNat]
+  unfold stirlingPowerMoment
+  rw [ENNReal.toReal_sum (fun order _ => by finiteness)]
+  simp only [ENNReal.toReal_mul, ENNReal.toReal_pow, ENNReal.toReal_div, ENNReal.toReal_ofNat,
+    ENNReal.toReal_natCast]
+  norm_num [Finset.sum_range_succ, Nat.stirlingSecond]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/TraceSum.lean b/formal/sphincs/SphincsSecurity/Proof/Base/TraceSum.lean
new file mode 100644
index 000000000..b1d39cf2d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/TraceSum.lean
@@ -0,0 +1,60 @@
+import Mathlib.Algebra.FreeMonoid.Basic
+
+namespace SphincsSecurity.TraceSum
+
+variable {Entry : Type} (charge : FreeMonoid Entry → Entry → Nat)
+
+def run (history : FreeMonoid Entry) : List Entry → Nat
+  | [] => 0
+  | entry :: tail => charge history entry + run (history * FreeMonoid.of entry) tail
+
+theorem run_nil (history : FreeMonoid Entry) : run charge history [] = 0 := rfl
+
+theorem run_cons (history : FreeMonoid Entry) (entry : Entry) (tail : List Entry) :
+    run charge history (entry :: tail) = charge history entry + run charge (history * FreeMonoid.of entry) tail := rfl
+
+theorem run_append (history : FreeMonoid Entry) (first second : List Entry) :
+    run charge history (first ++ second) = run charge history first + run charge (history * FreeMonoid.ofList first) second := by
+  induction first generalizing history with
+  | nil => simp only [List.nil_append, run_nil, FreeMonoid.ofList_nil, mul_one, Nat.zero_add]
+  | cons entry tail ih =>
+      simp only [List.cons_append, run_cons, ih, FreeMonoid.ofList_cons, mul_assoc, Nat.add_assoc]
+
+theorem run_le_length_mul (history : FreeMonoid Entry) (entries : List Entry) (bound : Nat)
+    (hbound : ∀ before entry after, entries = before ++ entry :: after → charge (history * FreeMonoid.ofList before) entry ≤ bound) :
+    run charge history entries ≤ entries.length * bound := by
+  induction entries generalizing history with
+  | nil => simp only [run_nil, List.length_nil, Nat.zero_mul, Nat.le_refl]
+  | cons entry tail ih =>
+      have hhead := hbound [] entry tail rfl
+      simp only [FreeMonoid.ofList_nil, mul_one] at hhead
+      have htail := ih (history * FreeMonoid.of entry) (by
+        intro before next after he
+        have h := hbound (entry :: before) next after (by simp only [List.cons_append, he])
+        simpa only [FreeMonoid.ofList_cons, mul_assoc] using h)
+      simpa only [run_cons, List.length_cons, Nat.add_mul, Nat.one_mul, Nat.add_comm] using Nat.add_le_add hhead htail
+
+theorem run_pos_iff (history : FreeMonoid Entry) (entries : List Entry) :
+    0 < run charge history entries ↔
+      ∃ before entry after, entries = before ++ entry :: after ∧ 0 < charge (history * FreeMonoid.ofList before) entry := by
+  induction entries generalizing history with
+  | nil => simp [run_nil]
+  | cons entry tail ih =>
+      rw [run_cons, Nat.add_pos_iff_pos_or_pos, ih]
+      constructor
+      · rintro (h | ⟨before, next, after, he, hp⟩)
+        · exact ⟨[], entry, tail, rfl, by simpa only [FreeMonoid.ofList_nil, mul_one] using h⟩
+        · refine ⟨entry :: before, next, after, by simp only [List.cons_append, he], ?_⟩
+          simpa only [FreeMonoid.ofList_cons, mul_assoc] using hp
+      · rintro ⟨before, next, after, he, hp⟩
+        cases before with
+        | nil =>
+            simp only [List.nil_append, List.cons.injEq] at he
+            obtain ⟨rfl, rfl⟩ := he
+            exact Or.inl (by simpa only [FreeMonoid.ofList_nil, mul_one] using hp)
+        | cons head before =>
+            simp only [List.cons_append, List.cons.injEq] at he
+            obtain ⟨rfl, he⟩ := he
+            exact Or.inr ⟨before, next, after, he, by simpa only [FreeMonoid.ofList_cons, mul_assoc] using hp⟩
+
+end SphincsSecurity.TraceSum
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableCompletion.lean b/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableCompletion.lean
new file mode 100644
index 000000000..f6977abbb
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableCompletion.lean
@@ -0,0 +1,184 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.PairedHiddenMiss
+import SphincsSecurity.Proof.Base.UniformTableDisclosure
+namespace SphincsSecurity.Concrete.UniformTableCompletion
+
+open _root_.OracleComp ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+variable {Coordinate Value : Type} [Fintype Coordinate] [DecidableEq Coordinate] [DecidableEq Value]
+
+noncomputable def complete (allowed : Coordinate → Finset Value) : SPMF (Coordinate → Value) :=
+  if h : ∀ coordinate, (allowed coordinate).Nonempty then liftM (uniformTable allowed h) else failure
+
+noncomputable def cell (allowed : Finset Value) : SPMF Value :=
+  if h : allowed.Nonempty then liftM (PMF.uniformOfFinset allowed h) else failure
+
+omit [DecidableEq Value] in
+theorem complete_of_nonempty (allowed : Coordinate → Finset Value)
+    (ha : ∀ coordinate, (allowed coordinate).Nonempty) :
+    complete allowed = liftM (uniformTable allowed ha) := by rw [complete, dif_pos ha]
+
+omit [DecidableEq Value] in
+theorem complete_of_empty (allowed : Coordinate → Finset Value)
+    (ha : ¬∀ coordinate, (allowed coordinate).Nonempty) : complete allowed = failure := by
+  rw [complete, dif_neg ha]
+
+theorem complete_apply (allowed : Coordinate → Finset Value) (labels : Coordinate → Value) :
+    complete allowed labels = if ∀ coordinate, labels coordinate ∈ allowed coordinate then
+      ((∏ coordinate, (allowed coordinate).card : Nat) : ENNReal)⁻¹ else 0 := by
+  by_cases ha : ∀ coordinate, (allowed coordinate).Nonempty
+  · rw [complete_of_nonempty allowed ha, SPMF.liftM_apply, uniformTable_apply]
+  · rw [complete_of_empty allowed ha, SPMF.failure_apply,
+      if_neg (fun h => ha (fun coordinate => ⟨labels coordinate, h coordinate⟩))]
+
+omit [Fintype Coordinate] [DecidableEq Coordinate] in
+theorem cell_apply (allowed : Finset Value) (value : Value) :
+    cell allowed value = if value ∈ allowed then (allowed.card : ENNReal)⁻¹ else 0 := by
+  by_cases ha : allowed.Nonempty
+  · rw [cell, dif_pos ha, SPMF.liftM_apply, PMF.uniformOfFinset_apply]
+    split <;> simp_all
+  · rw [cell, dif_neg ha, SPMF.failure_apply, if_neg (fun h => ha ⟨value, h⟩)]
+
+noncomputable def restrictionWeight (allowed reduced : Coordinate → Finset Value) : ENNReal :=
+  ((∏ coordinate, (reduced coordinate).card : Nat) : ENNReal) /
+    ((∏ coordinate, (allowed coordinate).card : Nat) : ENNReal)
+
+omit [DecidableEq Coordinate] [DecidableEq Value] in
+theorem weight_of_empty (allowed reduced : Coordinate → Finset Value)
+    (hr : ¬∀ coordinate, (reduced coordinate).Nonempty) : restrictionWeight allowed reduced = 0 := by
+  obtain ⟨coordinate, hcoordinate⟩ := not_forall.mp hr
+  have hcard : (reduced coordinate).card = 0 := by
+    simpa only [Finset.card_eq_zero] using Finset.not_nonempty_iff_eq_empty.mp hcoordinate
+  have hprod : (∏ coordinate, (reduced coordinate).card : Nat) = 0 :=
+    Finset.prod_eq_zero (Finset.mem_univ coordinate) hcard
+  simp only [restrictionWeight, hprod, Nat.cast_zero, ENNReal.zero_div]
+
+omit [DecidableEq Value] in
+theorem weight_tsum_complete (allowed reduced : Coordinate → Finset Value) :
+    restrictionWeight allowed reduced * (∑' labels, complete reduced labels) = restrictionWeight allowed reduced := by
+  by_cases hr : ∀ coordinate, (reduced coordinate).Nonempty
+  · simp only [complete_of_nonempty reduced hr, SPMF.liftM_apply, PMF.tsum_coe, mul_one]
+  · simp only [weight_of_empty allowed reduced hr, zero_mul]
+
+theorem restrict_mass (allowed reduced : Coordinate → Finset Value)
+    (hsub : ∀ coordinate, reduced coordinate ⊆ allowed coordinate) (labels : Coordinate → Value) :
+    (if ∀ coordinate, labels coordinate ∈ reduced coordinate then complete allowed labels else 0) =
+      restrictionWeight allowed reduced * complete reduced labels := by
+  by_cases hr : ∀ coordinate, (reduced coordinate).Nonempty
+  · have ha : ∀ coordinate, (allowed coordinate).Nonempty := fun coordinate => (hr coordinate).mono (hsub coordinate)
+    rw [complete_of_nonempty allowed ha, complete_of_nonempty reduced hr]
+    simpa only [SPMF.liftM_apply, restrictionWeight] using uniformTable_restrict allowed reduced ha hr hsub labels
+  · rw [complete_of_empty reduced hr, SPMF.failure_apply, mul_zero,
+      if_neg (fun h => hr (fun coordinate => ⟨labels coordinate, h coordinate⟩))]
+
+theorem restrict_guard (allowed reduced : Coordinate → Finset Value)
+    (hsub : ∀ coordinate, reduced coordinate ⊆ allowed coordinate) (event : (Coordinate → Value) → Prop)
+    (hguard : ∀ labels, (∀ coordinate, labels coordinate ∈ reduced coordinate) ↔
+      (∀ coordinate, labels coordinate ∈ allowed coordinate) ∧ event labels) (labels : Coordinate → Value) :
+    (if event labels then complete allowed labels else 0) =
+      restrictionWeight allowed reduced * complete reduced labels := by
+  rw [← restrict_mass allowed reduced hsub labels]
+  by_cases ha : ∀ coordinate, labels coordinate ∈ allowed coordinate
+  · simp only [hguard, ha, implies_true, true_and]
+  · simp only [complete_apply, ha, if_false, ite_self]
+
+omit [Fintype Coordinate] in
+theorem paired_subset (allowed : Coordinate → Finset Value) (child parent : Coordinate)
+    (candidate answer : Value) :
+    ∀ coordinate, pairedMissAllowed allowed child candidate parent answer coordinate ⊆ allowed coordinate := by
+  intro coordinate
+  unfold pairedMissAllowed eraseTableValue
+  by_cases hp : coordinate = parent
+  · subst coordinate
+    rw [Function.update_self]
+    apply Finset.Subset.trans (Finset.erase_subset _ _)
+    by_cases hc : parent = child
+    · subst parent
+      rw [Function.update_self]
+      exact Finset.erase_subset _ _
+    · rw [Function.update_of_ne hc]
+  · rw [Function.update_of_ne hp]
+    by_cases hc : coordinate = child
+    · subst coordinate
+      rw [Function.update_self]
+      exact Finset.erase_subset _ _
+    · rw [Function.update_of_ne hc]
+
+theorem paired_mass (allowed : Coordinate → Finset Value) (child parent : Coordinate) (hne : child ≠ parent)
+    (candidate answer : Value) (labels : Coordinate → Value) :
+    (if labels child ≠ candidate ∧ labels parent ≠ answer then complete allowed labels else 0) =
+      restrictionWeight allowed (pairedMissAllowed allowed child candidate parent answer) *
+        complete (pairedMissAllowed allowed child candidate parent answer) labels := by
+  have h := restrict_guard allowed _ (paired_subset allowed child parent candidate answer) _
+    (pairedMissAllowed_membership allowed child parent hne candidate answer) labels
+  by_cases hevent : labels child ≠ candidate ∧ labels parent ≠ answer
+  · simpa only [if_pos hevent] using h
+  · simpa only [if_neg hevent] using h
+
+theorem single_mass (allowed : Coordinate → Finset Value) (coordinate : Coordinate) (value : Value)
+    (labels : Coordinate → Value) :
+    (if labels coordinate ≠ value then complete allowed labels else 0) =
+      restrictionWeight allowed (eraseTableValue allowed coordinate value) *
+        complete (eraseTableValue allowed coordinate value) labels := by
+  have hsub : ∀ other, eraseTableValue allowed coordinate value other ⊆ allowed other := by
+    intro other
+    by_cases heq : other = coordinate
+    · subst other
+      simp only [eraseTableValue, Function.update_self]
+      exact Finset.erase_subset _ _
+    · rw [eraseTableValue, Function.update_of_ne heq]
+  have hguard (labels : Coordinate → Value) :
+      (∀ other, labels other ∈ eraseTableValue allowed coordinate value other) ↔
+        (∀ other, labels other ∈ allowed other) ∧ labels coordinate ≠ value := by
+    constructor
+    · intro h
+      refine ⟨fun other => hsub other (h other), ?_⟩
+      have hc := h coordinate
+      simp only [eraseTableValue, Function.update_self, Finset.mem_erase] at hc
+      exact hc.1
+    · rintro ⟨h, hne⟩ other
+      by_cases heq : other = coordinate
+      · subst other
+        simpa only [eraseTableValue, Function.update_self, Finset.mem_erase] using And.intro hne (h coordinate)
+      · simpa only [eraseTableValue, Function.update_of_ne heq] using h other
+  have h := restrict_guard allowed _ hsub _ hguard labels
+  by_cases hevent : labels coordinate ≠ value
+  · simpa only [if_pos hevent] using h
+  · simpa only [if_neg hevent] using h
+
+theorem disclose_mass (allowed : Coordinate → Finset Value) (coordinate : Coordinate) (value : Value)
+    (labels : Coordinate → Value) :
+    cell (allowed coordinate) value * complete (discloseTableValue allowed coordinate value) labels =
+      if labels coordinate = value then complete allowed labels else 0 := by
+  by_cases ha : ∀ coordinate, (allowed coordinate).Nonempty
+  · rw [complete_of_nonempty allowed ha, complete_of_nonempty _ (discloseTableValue_nonempty allowed ha coordinate value),
+      cell, dif_pos (ha coordinate)]
+    simpa only [SPMF.liftM_apply] using uniformTable_disclose_mass allowed ha coordinate value labels
+  · rw [complete_of_empty allowed ha, SPMF.failure_apply, ite_self]
+    by_cases hv : value ∈ allowed coordinate
+    · have hr : ¬∀ other, (discloseTableValue allowed coordinate value other).Nonempty := by
+        intro hr
+        apply ha
+        intro other
+        by_cases heq : other = coordinate
+        · subst other
+          exact ⟨value, hv⟩
+        · simpa only [discloseTableValue, Function.update_of_ne heq] using hr other
+      rw [complete_of_empty _ hr, SPMF.failure_apply, mul_zero]
+    · rw [cell_apply, if_neg hv, zero_mul]
+
+theorem bind_disclose {Result : Type} (allowed : Coordinate → Finset Value) (coordinate : Coordinate)
+    (next : Value → (Coordinate → Value) → SPMF Result) :
+    (complete allowed >>= fun labels => next (labels coordinate) labels) =
+      (cell (allowed coordinate) >>= fun value =>
+        complete (discloseTableValue allowed coordinate value) >>= next value) := by
+  classical
+  apply SPMF.ext
+  intro result
+  simp only [SPMF.bind_apply_eq_tsum, ← ENNReal.tsum_mul_left, ← mul_assoc, disclose_mass, ite_mul, zero_mul]
+  rw [ENNReal.tsum_comm]
+  simp
+
+end SphincsSecurity.Concrete.UniformTableCompletion
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableConditioning.lean b/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableConditioning.lean
new file mode 100644
index 000000000..afa6c6715
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableConditioning.lean
@@ -0,0 +1,41 @@
+import SphincsSecurity.Proof.Base.Prelude
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem uniformFinset_restrict_mass {α : Type} (source target : Finset α)
+    (hs : source.Nonempty) (ht : target.Nonempty) (hsub : target ⊆ source) (value : α) :
+    (if value ∈ target then PMF.uniformOfFinset source hs value else 0) =
+      ((target.card : ENNReal) / source.card) * PMF.uniformOfFinset target ht value := by
+  by_cases hv : value ∈ target
+  · rw [if_pos hv, PMF.uniformOfFinset_apply_of_mem hs (hsub hv), PMF.uniformOfFinset_apply_of_mem ht hv]
+    have ht0 : (target.card : ENNReal) ≠ 0 := by exact_mod_cast Nat.ne_of_gt ht.card_pos
+    rw [div_eq_mul_inv, mul_right_comm, ENNReal.mul_inv_cancel ht0 (by finiteness), one_mul]
+  · simp only [hv, if_false, PMF.uniformOfFinset_apply_of_notMem ht hv, mul_zero]
+
+variable {ι α : Type} [Fintype ι] [DecidableEq ι] [DecidableEq α]
+
+noncomputable def uniformTable (allowed : ι → Finset α) (hallowed : ∀ coordinate, (allowed coordinate).Nonempty) :
+    PMF (ι → α) := PMF.uniformOfFinset (Fintype.piFinset allowed) (Fintype.piFinset_nonempty.mpr hallowed)
+
+theorem uniformTable_apply (allowed : ι → Finset α) (hallowed : ∀ coordinate, (allowed coordinate).Nonempty)
+    (table : ι → α) :
+    uniformTable allowed hallowed table =
+      if ∀ coordinate, table coordinate ∈ allowed coordinate then
+        ((∏ coordinate, (allowed coordinate).card : Nat) : ENNReal)⁻¹ else 0 := by
+  simp only [uniformTable, PMF.uniformOfFinset_apply, Fintype.mem_piFinset, Fintype.card_piFinset]
+
+theorem uniformTable_restrict (allowed reduced : ι → Finset α)
+    (ha : ∀ coordinate, (allowed coordinate).Nonempty) (hr : ∀ coordinate, (reduced coordinate).Nonempty)
+    (hsub : ∀ coordinate, reduced coordinate ⊆ allowed coordinate) (table : ι → α) :
+    (if ∀ coordinate, table coordinate ∈ reduced coordinate then uniformTable allowed ha table else 0) =
+      (((∏ coordinate, (reduced coordinate).card : Nat) : ENNReal) /
+        ((∏ coordinate, (allowed coordinate).card : Nat) : ENNReal)) * uniformTable reduced hr table := by
+  simpa only [uniformTable, Fintype.mem_piFinset, Fintype.card_piFinset] using
+    uniformFinset_restrict_mass (Fintype.piFinset allowed) (Fintype.piFinset reduced)
+      (Fintype.piFinset_nonempty.mpr ha) (Fintype.piFinset_nonempty.mpr hr)
+      (Fintype.piFinset_subset reduced allowed hsub) table
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableDisclosure.lean b/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableDisclosure.lean
new file mode 100644
index 000000000..9c0870e81
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableDisclosure.lean
@@ -0,0 +1,42 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Base.UniformTableRestriction
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+variable {ι α : Type} [Fintype ι] [DecidableEq ι] [DecidableEq α]
+
+def discloseTableValue (allowed : ι → Finset α) (coordinate : ι) (value : α) : ι → Finset α :=
+  Function.update allowed coordinate {value}
+
+omit [Fintype ι] [DecidableEq α] in
+theorem discloseTableValue_nonempty (allowed : ι → Finset α)
+    (ha : ∀ coordinate, (allowed coordinate).Nonempty) (coordinate : ι) (value : α) :
+    ∀ other, (discloseTableValue allowed coordinate value other).Nonempty := by
+  intro other
+  by_cases heq : other = coordinate
+  · subst other
+    simp only [discloseTableValue, Function.update_self, Finset.singleton_nonempty]
+  · simpa only [discloseTableValue, Function.update_of_ne heq] using ha other
+
+theorem uniformTable_disclose_mass (allowed : ι → Finset α)
+    (ha : ∀ coordinate, (allowed coordinate).Nonempty) (coordinate : ι) (value : α) (labels : ι → α) :
+    PMF.uniformOfFinset (allowed coordinate) (ha coordinate) value *
+        uniformTable (discloseTableValue allowed coordinate value)
+          (discloseTableValue_nonempty allowed ha coordinate value) labels =
+      if labels coordinate = value then uniformTable allowed ha labels else 0 := by
+  rw [PMF.uniformOfFinset_apply]
+  by_cases hvalue : value ∈ allowed coordinate
+  · rw [if_pos hvalue]
+    have h := uniformTable_update_restrict allowed ha coordinate {value} (Finset.singleton_nonempty _)
+      (Finset.singleton_subset_iff.mpr hvalue) labels
+    simpa only [Finset.mem_singleton, Finset.card_singleton, Nat.cast_one, one_div, discloseTableValue] using h.symm
+  · rw [if_neg hvalue, zero_mul]
+    by_cases hlabels : labels coordinate = value
+    · rw [if_pos hlabels, uniformTable_apply,
+        if_neg (fun h => hvalue (hlabels ▸ h coordinate))]
+    · rw [if_neg hlabels]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableJoin.lean b/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableJoin.lean
new file mode 100644
index 000000000..2d9c02dee
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableJoin.lean
@@ -0,0 +1,104 @@
+import SphincsSecurity.Proof.Base.UniformTableProducts
+import SphincsSecurity.Proof.Base.UniformTableSplit
+namespace SphincsSecurity.Concrete.UniformTableSplit
+
+open _root_.OracleComp ENNReal
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+
+variable {Index Cell Answer : Type} (embed : Index → Cell) (hinj : Function.Injective embed)
+
+theorem join_eq_iff (table : Cell → Answer) (rows : Index → Answer) (outside : Outside embed → Answer) :
+    table = join embed hinj rows outside ↔ rows = table ∘ embed ∧ outside = fun cell : Outside embed => table cell.val := by
+  constructor
+  · intro heq
+    subst table
+    constructor
+    · funext index
+      exact (join_embed embed hinj rows outside index).symm
+    · funext cell
+      exact (join_outside embed hinj rows outside cell).symm
+  · rintro ⟨rfl, rfl⟩
+    exact (join_split embed hinj table).symm
+
+attribute [local irreducible] join
+
+section Mass
+
+attribute [local instance 10000] Classical.propDecidable
+
+theorem bind_map_join_apply (left : PMF (Index → Answer)) (right : PMF (Outside embed → Answer)) (table : Cell → Answer) :
+    (left.bind fun rows => right.map (join embed hinj rows)) table =
+      left (table ∘ embed) * right (fun cell => table cell.val) := by
+  simp only [PMF.bind_apply, PMF.map_apply]
+  rw [tsum_eq_single (table ∘ embed)]
+  · rw [tsum_eq_single (fun cell : Outside embed => table cell.val)]
+    · rw [if_pos (join_split embed hinj table).symm]
+    · intro outside hne
+      exact if_neg (fun h => hne ((join_eq_iff embed hinj table _ outside).mp h).2)
+  · intro rows hne
+    have hz : (∑' outside : Outside embed → Answer,
+        if table = join embed hinj rows outside then right outside else 0) = 0 := by
+      apply ENNReal.tsum_eq_zero.mpr
+      intro outside
+      exact if_neg (fun h => hne ((join_eq_iff embed hinj table rows outside).mp h).1)
+    rw [hz, mul_zero]
+
+end Mass
+
+variable [Fintype Index] [Fintype Cell] [DecidableEq Cell]
+
+include hinj in
+theorem prod_embed_mul_outside {M : Type} [CommMonoid M] (f : Cell → M) :
+    (∏ index, f (embed index)) * (∏ cell : Outside embed, f cell.val) = ∏ cell, f cell := by
+  letI : Fintype (Set.range embed) := Subtype.fintype (Set.range embed)
+  have he : (∏ index, f (embed index)) = ∏ cell : Set.range embed, f cell.val :=
+    Fintype.prod_equiv (Equiv.ofInjective embed hinj) _ _ (fun _ => rfl)
+  rw [he]
+  convert Fintype.prod_subtype_mul_prod_subtype (Set.range embed) f using 1
+  congr 1
+  exact Finset.prod_congr (by ext; simp) (fun _ _ => rfl)
+
+variable [DecidableEq Index] [Fintype Answer]
+
+theorem product_join (left : Index → PMF Answer) (right : Outside embed → PMF Answer) :
+    (FinitePmfProduct.law left).bind (fun rows => (FinitePmfProduct.law right).map (join embed hinj rows)) =
+      FinitePmfProduct.law (join embed hinj left right) := by
+  apply PMF.ext
+  intro table
+  rw [bind_map_join_apply]
+  simp only [FinitePmfProduct.apply]
+  have hp := prod_embed_mul_outside embed hinj (fun cell => join embed hinj left right cell (table cell))
+  simpa only [join_embed, join_outside, Function.comp_def] using hp
+
+variable [DecidableEq Answer]
+
+omit [Fintype Cell] [DecidableEq Index] [Fintype Answer] [DecidableEq Answer] in
+theorem join_nonempty (left : Index → Finset Answer) (right : Outside embed → Finset Answer)
+    (hl : ∀ index, (left index).Nonempty) (hr : ∀ cell, (right cell).Nonempty) :
+    ∀ cell, (join embed hinj left right cell).Nonempty := by
+  intro cell
+  by_cases hc : cell ∈ Set.range embed
+  · obtain ⟨index, rfl⟩ := hc
+    rw [join_embed]
+    exact hl index
+  · change (join embed hinj left right (⟨cell, hc⟩ : Outside embed).val).Nonempty
+    rw [join_outside]
+    exact hr ⟨cell, hc⟩
+
+theorem uniformTable_join (left : Index → Finset Answer) (right : Outside embed → Finset Answer)
+    (hl : ∀ index, (left index).Nonempty) (hr : ∀ cell, (right cell).Nonempty) :
+    (uniformTable left hl).bind (fun rows => (uniformTable right hr).map (join embed hinj rows)) =
+      uniformTable (join embed hinj left right) (join_nonempty embed hinj left right hl hr) := by
+  simp only [uniformTable_eq_product, product_join]
+  apply congrArg FinitePmfProduct.law
+  funext cell
+  by_cases hc : cell ∈ Set.range embed
+  · obtain ⟨index, rfl⟩ := hc
+    simp only [join_embed]
+  · change join embed hinj _ _ (⟨cell, hc⟩ : Outside embed).val = _
+    rw [join_outside]
+    have hrow := join_outside embed hinj left right (⟨cell, hc⟩ : Outside embed)
+    simp only [hrow]
+
+end SphincsSecurity.Concrete.UniformTableSplit
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableObservation.lean b/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableObservation.lean
new file mode 100644
index 000000000..010c13d0d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableObservation.lean
@@ -0,0 +1,90 @@
+import SphincsSecurity.Proof.Residual.RetainedObservation
+namespace SphincsSecurity.Concrete.UniformTableObservation
+
+open _root_.OracleComp OracleSpec UniformTableCompletion
+set_option backward.isDefEq.respectTransparency false
+
+variable {Coordinate Value AuxIndex : Type} [Fintype Coordinate] [DecidableEq Coordinate] [DecidableEq Value]
+  {auxSpec : OracleSpec AuxIndex}
+
+abbrev TableSpec (Coordinate Value : Type) := Coordinate →ₒ Value
+
+noncomputable def observedImpl (auxiliary : QueryImpl auxSpec SPMF) (table : Coordinate → Value) :
+    QueryImpl (auxSpec + TableSpec Coordinate Value) (StateT (Coordinate → Finset Value) SPMF)
+  | .inl input => StateT.mk fun allowed => (fun answer => (answer, allowed)) <$> auxiliary input
+  | .inr coordinate => StateT.mk fun allowed =>
+      pure (table coordinate, discloseTableValue allowed coordinate (table coordinate))
+
+noncomputable def lazyImpl (auxiliary : QueryImpl auxSpec SPMF) :
+    QueryImpl (auxSpec + TableSpec Coordinate Value) (StateT (Coordinate → Finset Value) SPMF)
+  | .inl input => StateT.mk fun allowed => (fun answer => (answer, allowed)) <$> auxiliary input
+  | .inr coordinate => StateT.mk fun allowed =>
+      (fun answer => (answer, discloseTableValue allowed coordinate answer)) <$> cell (allowed coordinate)
+
+noncomputable def observedRun {Result : Type} (auxiliary : QueryImpl auxSpec SPMF) (table : Coordinate → Value)
+    (computation : OracleComp (auxSpec + TableSpec Coordinate Value) Result) (allowed : Coordinate → Finset Value) :
+    SPMF (Result × (Coordinate → Finset Value)) :=
+  (simulateQ (observedImpl auxiliary table) computation).run allowed
+
+noncomputable def lazyRun {Result : Type} (auxiliary : QueryImpl auxSpec SPMF)
+    (computation : OracleComp (auxSpec + TableSpec Coordinate Value) Result) (allowed : Coordinate → Finset Value) :
+    SPMF (Result × (Coordinate → Finset Value)) :=
+  (simulateQ (lazyImpl auxiliary) computation).run allowed
+
+omit [Fintype Coordinate] [DecidableEq Value] in
+theorem observedRun_pure {Result : Type} (auxiliary : QueryImpl auxSpec SPMF) (table : Coordinate → Value)
+    (result : Result) (allowed : Coordinate → Finset Value) :
+    observedRun auxiliary table (pure result) allowed = pure (result, allowed) := by
+  simp only [observedRun, simulateQ_pure, StateT.run_pure]
+
+omit [Fintype Coordinate] [DecidableEq Value] in
+theorem lazyRun_pure {Result : Type} (auxiliary : QueryImpl auxSpec SPMF)
+    (result : Result) (allowed : Coordinate → Finset Value) :
+    lazyRun auxiliary (pure result) allowed = pure (result, allowed) := by
+  simp only [lazyRun, simulateQ_pure, StateT.run_pure]
+
+omit [Fintype Coordinate] [DecidableEq Value] in
+theorem observedRun_query_bind {Result : Type} (auxiliary : QueryImpl auxSpec SPMF) (table : Coordinate → Value)
+    (input : (auxSpec + TableSpec Coordinate Value).Domain)
+    (next : (auxSpec + TableSpec Coordinate Value).Range input → OracleComp (auxSpec + TableSpec Coordinate Value) Result)
+    (allowed : Coordinate → Finset Value) :
+    observedRun auxiliary table (liftM ((auxSpec + TableSpec Coordinate Value).query input) >>= next) allowed =
+      ((observedImpl auxiliary table input).run allowed >>= fun result =>
+        observedRun auxiliary table (next result.1) result.2) := by
+  simp only [observedRun, simulateQ_bind, simulateQ_spec_query, StateT.run_bind]
+
+omit [Fintype Coordinate] [DecidableEq Value] in
+theorem lazyRun_query_bind {Result : Type} (auxiliary : QueryImpl auxSpec SPMF)
+    (input : (auxSpec + TableSpec Coordinate Value).Domain)
+    (next : (auxSpec + TableSpec Coordinate Value).Range input → OracleComp (auxSpec + TableSpec Coordinate Value) Result)
+    (allowed : Coordinate → Finset Value) :
+    lazyRun auxiliary (liftM ((auxSpec + TableSpec Coordinate Value).query input) >>= next) allowed =
+      ((lazyImpl auxiliary input).run allowed >>= fun result => lazyRun auxiliary (next result.1) result.2) := by
+  simp only [lazyRun, simulateQ_bind, simulateQ_spec_query, StateT.run_bind]
+
+theorem run_posterior {Result : Type} (auxiliary : QueryImpl auxSpec SPMF)
+    (computation : OracleComp (auxSpec + TableSpec Coordinate Value) Result) (allowed : Coordinate → Finset Value) :
+    (complete allowed >>= fun table =>
+      (fun result => (table, result)) <$> observedRun auxiliary table computation allowed) =
+        (lazyRun auxiliary computation allowed >>= fun result =>
+          (fun table => (table, result)) <$> complete result.2) := by
+  induction computation using OracleComp.inductionOn generalizing allowed with
+  | pure result => simp only [observedRun_pure, lazyRun_pure, pure_bind, ← bind_pure_comp]
+  | query_bind input next ih =>
+      cases input with
+      | inl input =>
+          simp only [observedRun_query_bind, lazyRun_query_bind, observedImpl, lazyImpl,
+            StateT.run_mk, bind_map_left, map_bind, bind_assoc]
+          rw [RetainedObservation.bind_comm]
+          exact congrArg (fun continuation => auxiliary input >>= continuation)
+            (funext fun answer => ih answer allowed)
+      | inr coordinate =>
+          simp only [observedRun_query_bind, lazyRun_query_bind, observedImpl, lazyImpl,
+            StateT.run_mk, pure_bind, bind_map_left, bind_assoc]
+          rw [bind_disclose allowed coordinate (fun answer table =>
+            (fun result => (table, result)) <$>
+              observedRun auxiliary table (next answer) (discloseTableValue allowed coordinate answer))]
+          exact congrArg (fun continuation => cell (allowed coordinate) >>= continuation)
+            (funext fun answer => ih answer (discloseTableValue allowed coordinate answer))
+
+end SphincsSecurity.Concrete.UniformTableObservation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableObservationErasure.lean b/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableObservationErasure.lean
new file mode 100644
index 000000000..29899e633
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableObservationErasure.lean
@@ -0,0 +1,72 @@
+import SphincsSecurity.Proof.Base.UniformTableObservation
+namespace SphincsSecurity.Concrete.UniformTableObservation
+
+open _root_.OracleComp OracleSpec UniformTableCompletion RetainedObservation
+set_option backward.isDefEq.respectTransparency false
+
+variable {Coordinate Value AuxIndex : Type} [Fintype Coordinate] [DecidableEq Coordinate] [DecidableEq Value]
+  {auxSpec : OracleSpec AuxIndex}
+
+noncomputable def fixedImpl (auxiliary : QueryImpl auxSpec SPMF) (table : Coordinate → Value) :
+    QueryImpl (auxSpec + TableSpec Coordinate Value) SPMF
+  | .inl input => auxiliary input
+  | .inr coordinate => pure (table coordinate)
+
+omit [Fintype Coordinate] [DecidableEq Value] in
+theorem observedRun_forget {Result : Type} (auxiliary : QueryImpl auxSpec SPMF) (table : Coordinate → Value)
+    (computation : OracleComp (auxSpec + TableSpec Coordinate Value) Result) (allowed : Coordinate → Finset Value) :
+    Prod.fst <$> observedRun auxiliary table computation allowed = simulateQ (fixedImpl auxiliary table) computation := by
+  induction computation using OracleComp.inductionOn generalizing allowed with
+  | pure value => simp only [observedRun_pure, map_pure, simulateQ_pure]
+  | query_bind input next ih =>
+      cases input <;> simp only [observedRun_query_bind, observedImpl, fixedImpl, StateT.run_mk,
+        bind_map_left, pure_bind, map_bind, ih, simulateQ_bind, simulateQ_spec_query]
+
+omit [Fintype Coordinate] [DecidableEq Value] in
+theorem lazyRun_nonempty {Result : Type} (auxiliary : QueryImpl auxSpec SPMF)
+    (computation : OracleComp (auxSpec + TableSpec Coordinate Value) Result) (allowed : Coordinate → Finset Value)
+    (ha : ∀ coordinate, (allowed coordinate).Nonempty)
+    (result : Result × (Coordinate → Finset Value)) (hr : lazyRun auxiliary computation allowed result ≠ 0) :
+    ∀ coordinate, (result.2 coordinate).Nonempty := by
+  induction computation using OracleComp.inductionOn generalizing allowed result with
+  | pure value =>
+      simp only [lazyRun_pure, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+      subst result
+      exact ha
+  | query_bind input next ih =>
+      cases input with
+      | inl input =>
+          simp only [lazyRun_query_bind, lazyImpl, StateT.run_mk, bind_map_left] at hr
+          obtain ⟨answer, _, hnext⟩ := (bind_nonzero _ _ _).mp hr
+          exact ih answer allowed ha result hnext
+      | inr coordinate =>
+          simp only [lazyRun_query_bind, lazyImpl, StateT.run_mk, bind_map_left] at hr
+          obtain ⟨answer, _, hnext⟩ := (bind_nonzero _ _ _).mp hr
+          exact ih answer _ (discloseTableValue_nonempty allowed ha coordinate answer) result hnext
+
+theorem run_erasure {Result : Type} (auxiliary : QueryImpl auxSpec SPMF)
+    (computation : OracleComp (auxSpec + TableSpec Coordinate Value) Result) (allowed : Coordinate → Finset Value)
+    (ha : ∀ coordinate, (allowed coordinate).Nonempty) :
+    (complete allowed >>= fun table => observedRun auxiliary table computation allowed) = lazyRun auxiliary computation allowed := by
+  have h := congrArg (fun law : SPMF ((Coordinate → Value) × (Result × (Coordinate → Finset Value))) => Prod.snd <$> law)
+    (run_posterior auxiliary computation allowed)
+  simp only [← bind_pure_comp, bind_assoc, pure_bind, bind_pure] at h
+  rw [h]
+  have hfinish : (lazyRun auxiliary computation allowed >>= fun result =>
+      (fun _ : Coordinate → Value => result) <$> complete result.2) =
+        (lazyRun auxiliary computation allowed >>= fun result => pure result) := by
+    apply RetainedObservation.bind_congr
+    intro result hr
+    rw [complete_of_nonempty _ (lazyRun_nonempty auxiliary computation allowed ha result hr), ← bind_pure_comp]
+    exact lift_bind_const _ _
+  simpa only [← bind_pure_comp, bind_pure] using hfinish
+
+theorem run_marginal {Result : Type} (auxiliary : QueryImpl auxSpec SPMF)
+    (computation : OracleComp (auxSpec + TableSpec Coordinate Value) Result) (allowed : Coordinate → Finset Value)
+    (ha : ∀ coordinate, (allowed coordinate).Nonempty) :
+    (complete allowed >>= fun table => simulateQ (fixedImpl auxiliary table) computation) =
+      Prod.fst <$> lazyRun auxiliary computation allowed := by
+  rw [← run_erasure auxiliary computation allowed ha, map_bind]
+  simp only [observedRun_forget]
+
+end SphincsSecurity.Concrete.UniformTableObservation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableOverwrite.lean b/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableOverwrite.lean
new file mode 100644
index 000000000..279ee7ebf
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableOverwrite.lean
@@ -0,0 +1,41 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Base.UniformTableSplit
+namespace SphincsSecurity.Concrete.UniformTableSplit
+
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+variable {Index Cell Answer : Type}
+
+noncomputable def overwrite (embed : Index → Cell) (hinj : Function.Injective embed)
+    (rows : Index → Answer) (table : Cell → Answer) : Cell → Answer :=
+  join embed hinj rows (fun cell => table cell.val)
+
+theorem overwrite_embed (embed : Index → Cell) (hinj : Function.Injective embed)
+    (rows : Index → Answer) (table : Cell → Answer) (index : Index) :
+    overwrite embed hinj rows table (embed index) = rows index :=
+  join_embed embed hinj rows _ index
+
+theorem overwrite_outside (embed : Index → Cell) (hinj : Function.Injective embed)
+    (rows : Index → Answer) (table : Cell → Answer) (cell : Cell) (hcell : cell ∉ Set.range embed) :
+    overwrite embed hinj rows table cell = table cell :=
+  join_outside embed hinj rows _ ⟨cell, hcell⟩
+
+theorem overwrite_join (embed : Index → Cell) (hinj : Function.Injective embed)
+    (rows previous : Index → Answer) (outside : Outside embed → Answer) :
+    overwrite embed hinj rows (join embed hinj previous outside) = join embed hinj rows outside := by
+  unfold overwrite
+  congr 1
+  funext cell
+  exact join_outside embed hinj previous outside cell
+
+variable [Fintype Index] [Fintype Cell] [Fintype Answer] [Nonempty Answer]
+  [DecidableEq Index] [DecidableEq Cell]
+
+theorem uniform_overwrite (embed : Index → Cell) (hinj : Function.Injective embed) (rows : Index → Answer) :
+    (PMF.uniformOfFintype (Cell → Answer)).map (overwrite embed hinj rows) =
+      (PMF.uniformOfFintype (Outside embed → Answer)).map (join embed hinj rows) := by
+  rw [uniform_join embed hinj]
+  simp only [PMF.map_bind, PMF.map_comp, Function.comp_def, overwrite_join, PMF.bind_const]
+
+end SphincsSecurity.Concrete.UniformTableSplit
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableProducts.lean b/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableProducts.lean
new file mode 100644
index 000000000..c44080775
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableProducts.lean
@@ -0,0 +1,52 @@
+import SphincsSecurity.Proof.Base.FirstSuccessFamily
+import SphincsSecurity.Proof.Base.UniformTableCompletion
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp ENNReal
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+
+theorem uniformTable_eq_product {Coordinate Value : Type} [Fintype Coordinate] [DecidableEq Coordinate]
+    [Fintype Value] [DecidableEq Value] (allowed : Coordinate → Finset Value)
+    (ha : ∀ coordinate, (allowed coordinate).Nonempty) :
+    uniformTable allowed ha = FinitePmfProduct.law (fun coordinate => PMF.uniformOfFinset (allowed coordinate) (ha coordinate)) := by
+  apply PMF.ext
+  intro table
+  rw [uniformTable_apply, FinitePmfProduct.apply]
+  simp only [PMF.uniformOfFinset_apply]
+  by_cases ht : ∀ coordinate, table coordinate ∈ allowed coordinate
+  · simp only [ht, implies_true, if_true]
+    rw [Nat.cast_prod, ENNReal.prod_inv_distrib (fun _ _ _ _ _ => Or.inr (by finiteness))]
+  · rw [if_neg ht]
+    obtain ⟨coordinate, hc⟩ := not_forall.mp ht
+    symm
+    exact Finset.prod_eq_zero (Finset.mem_univ coordinate) (if_neg hc)
+
+theorem FinitePmfProduct.uncurry {Index Coordinate Value : Type} [Fintype Index] [DecidableEq Index]
+    [Fintype Coordinate] [DecidableEq Coordinate] [Fintype Value]
+    (family : Index → Coordinate → PMF Value) :
+    (law (fun index => law (family index))).map Function.uncurry =
+      law (fun coordinate : Index × Coordinate => family coordinate.1 coordinate.2) := by
+  classical
+  apply PMF.ext
+  intro table
+  rw [PMF.map_apply, tsum_eq_single (Function.curry table)]
+  · simp only [Function.uncurry_curry, if_true, apply]
+    rw [Fintype.prod_prod_type]
+    rfl
+  · intro candidate hne
+    apply if_neg
+    intro heq
+    apply hne
+    exact (congrArg Function.curry heq).symm
+
+theorem uniformTable_univ {Coordinate Value : Type} [Fintype Coordinate] [DecidableEq Coordinate]
+    [Fintype Value] [DecidableEq Value] [Nonempty Value] :
+    uniformTable (fun _ : Coordinate => (Finset.univ : Finset Value)) (fun _ => Finset.univ_nonempty) =
+      PMF.uniformOfFintype (Coordinate → Value) := by
+  apply PMF.ext
+  intro table
+  simp only [uniformTable_apply, Finset.mem_univ, implies_true, if_true, Finset.card_univ,
+    Finset.prod_const, Nat.cast_pow, PMF.uniformOfFintype_apply, Fintype.card_fun]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableRestriction.lean b/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableRestriction.lean
new file mode 100644
index 000000000..b4c1d765d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableRestriction.lean
@@ -0,0 +1,98 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Base.UniformTableConditioning
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+variable {ι α : Type} [Fintype ι] [DecidableEq ι] [DecidableEq α]
+
+omit [DecidableEq α] in
+theorem piFinset_update_card (allowed : ι → Finset α) (coordinate : ι) (values : Finset α) :
+    (Fintype.piFinset (Function.update allowed coordinate values)).card =
+      values.card * ∏ other ∈ Finset.univ.erase coordinate, (allowed other).card := by
+  rw [Fintype.card_piFinset]
+  have h : (fun other => (Function.update allowed coordinate values other).card) =
+      Function.update (fun other => (allowed other).card) coordinate values.card := by
+    funext other
+    by_cases heq : other = coordinate <;> simp only [Function.update_apply, heq, if_true, if_false]
+  rw [h, Finset.prod_update_of_mem (Finset.mem_univ coordinate), Finset.sdiff_singleton_eq_erase]
+
+omit [DecidableEq α] in
+theorem piFinset_update_card_ratio (allowed : ι → Finset α)
+    (ha : ∀ coordinate, (allowed coordinate).Nonempty) (coordinate : ι) (values : Finset α) :
+    ((Fintype.piFinset (Function.update allowed coordinate values)).card : ENNReal) /
+        (Fintype.piFinset allowed).card = (values.card : ENNReal) / (allowed coordinate).card := by
+  rw [piFinset_update_card, Fintype.card_piFinset,
+    ← Finset.mul_prod_erase Finset.univ (fun other => (allowed other).card) (Finset.mem_univ coordinate)]
+  have hrest : ((∏ other ∈ Finset.univ.erase coordinate, (allowed other).card : Nat) : ENNReal) ≠ 0 := by
+    exact_mod_cast Finset.prod_ne_zero_iff.mpr (fun other _ => Nat.ne_of_gt (ha other).card_pos)
+  rw [Nat.cast_mul, Nat.cast_mul]
+  rw [ENNReal.mul_div_mul_right _ _ hrest (by finiteness)]
+
+theorem uniformTable_update_restrict (allowed : ι → Finset α)
+    (ha : ∀ coordinate, (allowed coordinate).Nonempty) (coordinate : ι) (values : Finset α)
+    (hv : values.Nonempty) (hsub : values ⊆ allowed coordinate) (table : ι → α) :
+    (if table coordinate ∈ values then uniformTable allowed ha table else 0) =
+      ((values.card : ENNReal) / (allowed coordinate).card) *
+        uniformTable (Function.update allowed coordinate values)
+          (by intro other; by_cases heq : other = coordinate
+              · simpa only [heq, Function.update_self] using hv
+              · simpa only [Function.update_of_ne heq] using ha other) table := by
+  classical
+  letI : DecidableEq (ι → α) := Classical.decEq _
+  let reduced := Function.update allowed coordinate values
+  have hred : ∀ other, (reduced other).Nonempty := by
+    intro other
+    by_cases heq : other = coordinate <;> simp only [reduced, Function.update_apply, heq, if_true, if_false]
+    · exact hv
+    · exact ha other
+  have hsub' : Fintype.piFinset reduced ⊆ Fintype.piFinset allowed := by
+    apply Fintype.piFinset_subset
+    intro other
+    by_cases heq : other = coordinate <;> simp only [reduced, Function.update_apply, heq, if_true, if_false]
+    · simpa only [heq] using hsub
+    · exact Finset.Subset.refl _
+  have h := uniformFinset_restrict_mass (Fintype.piFinset allowed) (Fintype.piFinset reduced)
+    (Fintype.piFinset_nonempty.mpr ha) (Fintype.piFinset_nonempty.mpr hred) hsub' table
+  rw [show (Fintype.piFinset reduced).card =
+      (Fintype.piFinset (Function.update allowed coordinate values)).card from rfl,
+    piFinset_update_card_ratio allowed ha coordinate values] at h
+  change (if table ∈ Fintype.piFinset reduced then uniformTable allowed ha table else 0) =
+    ((values.card : ENNReal) / (allowed coordinate).card) * uniformTable reduced hred table at h
+  rw [← h]
+  by_cases ht : ∀ other, table other ∈ allowed other
+  · have heq : table ∈ Fintype.piFinset reduced ↔ table coordinate ∈ values := by
+      rw [Fintype.piFinset_update_eq_filter_piFinset_mem allowed coordinate hsub, Finset.mem_filter,
+        Fintype.mem_piFinset]
+      exact and_iff_right ht
+    simp only [heq]
+  · have hz : uniformTable allowed ha table = 0 := by rw [uniformTable_apply, if_neg ht]
+    simp only [hz, ite_self]
+
+theorem probEvent_uniformTable_member (allowed : ι → Finset α)
+    (ha : ∀ coordinate, (allowed coordinate).Nonempty) (coordinate : ι) (values : Finset α)
+    (hv : values.Nonempty) (hsub : values ⊆ allowed coordinate) :
+    Pr[fun table => table coordinate ∈ values | uniformTable allowed ha] =
+      (values.card : ENNReal) / (allowed coordinate).card := by
+  simp only [probEvent_eq_tsum_ite, PMF.probOutput_eq_apply,
+    uniformTable_update_restrict allowed ha coordinate values hv hsub, ENNReal.tsum_mul_left, PMF.tsum_coe, mul_one]
+
+theorem probEvent_uniformTable_eq (allowed : ι → Finset α)
+    (ha : ∀ coordinate, (allowed coordinate).Nonempty) (coordinate : ι) (candidate : α) :
+    Pr[fun table => table coordinate = candidate | uniformTable allowed ha] =
+      if candidate ∈ allowed coordinate then ((allowed coordinate).card : ENNReal)⁻¹ else 0 := by
+  by_cases hc : candidate ∈ allowed coordinate
+  · have h := probEvent_uniformTable_member allowed ha coordinate {candidate} (Finset.singleton_nonempty _)
+      (Finset.singleton_subset_iff.mpr hc)
+    simpa only [Finset.mem_singleton, Finset.card_singleton, Nat.cast_one, one_div, hc, if_true] using h
+  · simp only [hc, if_false, probEvent_eq_tsum_ite, PMF.probOutput_eq_apply]
+    apply ENNReal.tsum_eq_zero.mpr
+    intro table
+    by_cases heq : table coordinate = candidate
+    · have hn : ¬ ∀ other, table other ∈ allowed other := fun h => hc (heq ▸ h coordinate)
+      simp only [heq, if_true, uniformTable_apply, hn, if_false]
+    · simp only [heq, if_false]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableSplit.lean b/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableSplit.lean
new file mode 100644
index 000000000..0be628ffa
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/UniformTableSplit.lean
@@ -0,0 +1,111 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Statement
+
+namespace SphincsSecurity.Concrete.UniformTableSplit
+
+open _root_.OracleComp ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+variable {Index Cell Answer : Type}
+
+abbrev Outside (embed : Index → Cell) := {cell : Cell // cell ∉ Set.range embed}
+
+theorem inclusion_not_range {α : Type} {small large : Set α} (hsubset : small ⊆ large)
+    (cell : large) (houtside : cell.val ∉ small) : cell ∉ Set.range (Set.inclusion hsubset) := by
+  rintro ⟨input, heq⟩
+  exact houtside ((congrArg Subtype.val heq) ▸ input.property)
+
+noncomputable def split (embed : Index → Cell) (hinj : Function.Injective embed) :
+    (Cell → Answer) ≃ (Index → Answer) × (Outside embed → Answer) :=
+  (Equiv.arrowCongr ((Equiv.Set.sumCompl (Set.range embed)).symm.trans
+    ((Equiv.ofInjective embed hinj).symm.sumCongr (Equiv.refl (Outside embed)))) (Equiv.refl Answer)).trans
+      (Equiv.sumArrowEquivProdArrow _ _ _)
+
+theorem split_fst (embed : Index → Cell) (hinj : Function.Injective embed) (table : Cell → Answer) :
+    (split embed hinj table).1 = table ∘ embed := by
+  funext index
+  simp [split, Equiv.sumArrowEquivProdArrow, Equiv.ofInjective]
+
+theorem split_snd (embed : Index → Cell) (hinj : Function.Injective embed) (table : Cell → Answer) :
+    (split embed hinj table).2 = fun cell => table cell.val := by
+  funext cell
+  simp [split, Equiv.sumArrowEquivProdArrow, Equiv.ofInjective]
+  rfl
+
+noncomputable def join (embed : Index → Cell) (hinj : Function.Injective embed)
+    (rows : Index → Answer) (outside : Outside embed → Answer) : Cell → Answer :=
+  (split embed hinj).symm (rows, outside)
+
+@[simp] theorem join_embed (embed : Index → Cell) (hinj : Function.Injective embed)
+    (rows : Index → Answer) (outside : Outside embed → Answer) (index : Index) :
+    join embed hinj rows outside (embed index) = rows index := by
+  have h := congrArg Prod.fst ((split embed hinj).apply_symm_apply (rows, outside))
+  rw [split_fst] at h
+  exact congrFun h index
+
+@[simp] theorem join_outside (embed : Index → Cell) (hinj : Function.Injective embed)
+    (rows : Index → Answer) (outside : Outside embed → Answer) (cell : Outside embed) :
+    join embed hinj rows outside cell.val = outside cell := by
+  have h := congrArg Prod.snd ((split embed hinj).apply_symm_apply (rows, outside))
+  rw [split_snd] at h
+  exact congrFun h cell
+
+@[simp] theorem join_split (embed : Index → Cell) (hinj : Function.Injective embed) (table : Cell → Answer) :
+    join embed hinj (table ∘ embed) (fun cell => table cell.val) = table := by
+  rw [← split_fst embed hinj table, ← split_snd embed hinj table]
+  exact (split embed hinj).symm_apply_apply table
+
+theorem uniform_product {Left Right : Type} [Fintype Left] [Fintype Right] [Nonempty Left] [Nonempty Right] :
+    PMF.uniformOfFintype (Left × Right) =
+      (PMF.uniformOfFintype Left).bind (fun left => (PMF.uniformOfFintype Right).map (fun right => (left, right))) := by
+  classical
+  letI : DecidableEq Left := Classical.decEq Left
+  letI : DecidableEq Right := Classical.decEq Right
+  apply PMF.ext
+  rintro ⟨left, right⟩
+  have hmap : ∀ a : Left,
+      (PMF.uniformOfFintype Right).map (fun b => (a, b)) (left, right) =
+        if a = left then PMF.uniformOfFintype Right right else 0 := by
+    intro a
+    rw [PMF.map_apply]
+    by_cases ha : a = left
+    · subst a
+      rw [if_pos rfl, tsum_eq_single right]
+      · rw [if_pos rfl]
+      · intro b hb
+        exact if_neg (fun h => hb (congrArg Prod.snd h).symm)
+    · rw [if_neg ha]
+      apply ENNReal.tsum_eq_zero.mpr
+      intro b
+      exact if_neg (fun h => ha (congrArg Prod.fst h).symm)
+  rw [PMF.bind_apply]
+  simp only [hmap, mul_ite, mul_zero]
+  rw [tsum_eq_single left]
+  · simp only [if_true, PMF.uniformOfFintype_apply]
+    rw [Fintype.card_prod, Nat.cast_mul, ENNReal.mul_inv (by simp) (by simp)]
+  · intro a ha
+    exact if_neg ha
+
+variable [Fintype Index] [Fintype Cell] [Fintype Answer] [Nonempty Answer]
+  [DecidableEq Index] [DecidableEq Cell]
+
+theorem uniform_join (embed : Index → Cell) (hinj : Function.Injective embed) :
+    PMF.uniformOfFintype (Cell → Answer) =
+      (PMF.uniformOfFintype (Index → Answer)).bind (fun rows =>
+        (PMF.uniformOfFintype (Outside embed → Answer)).map (join embed hinj rows)) := by
+  unfold join
+  have h := PMF.uniformOfFintype_map_of_bijective (split (Answer := Answer) embed hinj).symm
+    (split embed hinj).symm.bijective
+  rw [uniform_product, PMF.map_bind] at h
+  simpa only [PMF.map_comp, Function.comp_def] using h.symm
+
+theorem uniform_bind_split {Result : Type} (embed : Index → Cell) (hinj : Function.Injective embed)
+    (next : (Cell → Answer) → PMF Result) :
+    (PMF.uniformOfFintype (Cell → Answer)).bind next =
+      (PMF.uniformOfFintype (Index → Answer)).bind (fun rows =>
+        (PMF.uniformOfFintype (Outside embed → Answer)).bind (fun outside => next (join embed hinj rows outside))) := by
+  conv_lhs => rw [uniform_join embed hinj]
+  simp only [PMF.bind_bind, PMF.bind_map, Function.comp_def]
+
+end SphincsSecurity.Concrete.UniformTableSplit
diff --git a/formal/sphincs/SphincsSecurity/Proof/Base/WeightedQuery.lean b/formal/sphincs/SphincsSecurity/Proof/Base/WeightedQuery.lean
new file mode 100644
index 000000000..7c3d74a55
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Base/WeightedQuery.lean
@@ -0,0 +1,66 @@
+import SphincsSecurity.Proof.Residual.RetainedObservation
+namespace SphincsSecurity.Concrete.WeightedQuery
+
+open _root_.OracleComp OracleSpec ENNReal
+set_option backward.isDefEq.respectTransparency false
+
+variable {Index State : Type} {spec : OracleSpec Index}
+
+noncomputable def implementation (base : QueryImpl spec (StateT State SPMF))
+    (factor : State → spec.Domain → ENNReal) : QueryImpl spec (StateT (State × ENNReal) SPMF) :=
+  fun input => StateT.mk fun state =>
+    (fun result => (result.1, (result.2, state.2 * factor state.1 input))) <$> (base input).run state.1
+
+noncomputable def run {Result : Type} (base : QueryImpl spec (StateT State SPMF))
+    (factor : State → spec.Domain → ENNReal) (computation : OracleComp spec Result) (state : State × ENNReal) :=
+  (simulateQ (implementation base factor) computation).run state
+
+theorem run_forget {Result : Type} (base : QueryImpl spec (StateT State SPMF))
+    (factor : State → spec.Domain → ENNReal) (computation : OracleComp spec Result) (state : State × ENNReal) :
+    (fun result => (result.1, result.2.1)) <$> run base factor computation state =
+      (simulateQ base computation).run state.1 := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [run, simulateQ_pure, StateT.run_pure, map_pure]
+  | query_bind input next ih =>
+      simp only [run, simulateQ_bind, simulateQ_spec_query, StateT.run_bind, implementation,
+        StateT.run_mk, bind_map_left, map_bind]
+      exact congrArg ((base input).run state.1 >>= ·) (funext fun result => ih result.1 _)
+
+theorem run_payoff {Result : Type} (left right : QueryImpl spec (StateT State SPMF))
+    (factor : State → spec.Domain → ENNReal)
+    (hstep : ∀ state input result, (left input).run state result = factor state input * (right input).run state result)
+    (computation : OracleComp spec Result) (state : State) (weight : ENNReal) (payoff : Result × State → ENNReal) :
+    weight * (∑' result, Pr[= result | (simulateQ left computation).run state] * payoff result) =
+      ∑' result, Pr[= result | run right factor computation (state, weight)] *
+        (result.2.2 * payoff (result.1, result.2.1)) := by
+  induction computation using OracleComp.inductionOn generalizing state weight with
+  | pure value => simp only [run, simulateQ_pure, StateT.run_pure, tsum_probOutput_pure_mul]
+  | query_bind input next ih =>
+      simp only [run, simulateQ_bind, simulateQ_spec_query, StateT.run_bind, implementation,
+        StateT.run_mk, bind_map_left, tsum_probOutput_bind_mul]
+      simp only [run] at ih
+      simp_rw [← ih]
+      rw [← ENNReal.tsum_mul_left]
+      apply tsum_congr
+      intro result
+      simp only [SPMF.probOutput_eq_apply, hstep]
+      ring
+
+theorem run_preserves {Result : Type} (base : QueryImpl spec (StateT State SPMF))
+    (factor : State → spec.Domain → ENNReal) (invariant : State × ENNReal → Prop)
+    (hstep : ∀ state, invariant state → ∀ input result, (base input).run state.1 result ≠ 0 →
+      invariant (result.2, state.2 * factor state.1 input))
+    (computation : OracleComp spec Result) (state : State × ENNReal) (hs : invariant state)
+    (result : Result × State × ENNReal) (hr : run base factor computation state result ≠ 0) : invariant result.2 := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      simp only [run, simulateQ_pure, StateT.run_pure, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+      subst result
+      exact hs
+  | query_bind input next ih =>
+      simp only [run, simulateQ_bind, simulateQ_spec_query, StateT.run_bind, implementation, StateT.run_mk,
+        bind_map_left, RetainedObservation.bind_nonzero] at hr
+      obtain ⟨middle, hm, hr⟩ := hr
+      exact ih middle.1 (middle.2, state.2 * factor state.1 input) (hstep state hs input middle hm) result hr
+
+end SphincsSecurity.Concrete.WeightedQuery
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainActualBudget.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainActualBudget.lean
new file mode 100644
index 000000000..3385bf42f
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainActualBudget.lean
@@ -0,0 +1,60 @@
+import SphincsSecurity.Proof.Base.QueryCapState
+import SphincsSecurity.Proof.Chains.AdaptiveChainCountedRows
+import SphincsSecurity.Proof.Base.QueryPause
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+  {AuxIndex : Type} {auxSpec : OracleSpec AuxIndex} {n : Nat} {Result Memory : Type}
+  (auxiliary : State → QueryImpl auxSpec PMF)
+  (computation : State → OracleComp (auxSpec + PrefixSpec n State) Result)
+  (cost : Result → Nat) (budget : Nat)
+  (hcharge : ∀ endpoint result, result ∈ support (QueryCap.counted IsPrefixQuery (computation endpoint)) → result.2 ≤ cost result.1)
+  (hreal : ∀ result ∈ (realRun auxiliary computation (fun _ _ => none)).support, cost result.2.1 ≤ budget)
+  (hsmall : budget < Fintype.card State)
+
+include hcharge hreal hsmall
+
+theorem lazyRun_counted_le_of_real (endpoint : State) (result : (Result × Nat) × (Fin n → State → Option State))
+    (hresult : result ∈ (lazyRun (auxiliary endpoint) (QueryCap.counted IsPrefixQuery (computation endpoint)) (fun _ _ => none)).support) :
+    result.1.2 ≤ budget := by
+  apply QueryCap.counted_state_le_of_cap_valid IsPrefixQuery (lazyImpl (auxiliary endpoint)) (computation endpoint) budget
+    (fun _ _ => none) _ result hresult
+  intro capped hcapped
+  have hsource : (endpoint, capped) ∈ (idealRun auxiliary
+      (fun endpoint => QueryCap.run IsPrefixQuery (computation endpoint) budget) (fun _ _ => none)).support := by
+    rw [idealRun, PMF.mem_support_bind_iff]
+    refine ⟨endpoint, PMF.mem_support_uniformOfFintype endpoint, ?_⟩
+    rw [PMF.mem_support_map_iff]
+    exact ⟨capped, hcapped, rfl⟩
+  obtain ⟨finished, hfinished, _⟩ := idealRun_cap_valid auxiliary computation cost budget hcharge hreal hsmall (endpoint, capped) hsource
+  change capped.1 = some finished at hfinished
+  rw [hfinished]
+  exact Option.some_ne_none finished
+
+theorem lazyRun_pause_budget_of_real (endpoint : State) (stop : Memory → Prop) [DecidablePred stop]
+    (step : (input : (auxSpec + PrefixSpec n State).Domain) → (auxSpec + PrefixSpec n State).Range input → Memory → Memory)
+    (memory : Memory)
+    (middle : ((Memory × OracleComp (auxSpec + PrefixSpec n State) Result) × Nat) × (Fin n → State → Option State))
+    (hmiddle : middle ∈ (lazyRun (auxiliary endpoint)
+      (QueryCap.counted IsPrefixQuery (QueryPause.run stop step (computation endpoint) memory)) (fun _ _ => none)).support)
+    (result : (Result × Nat) × (Fin n → State → Option State))
+    (hresult : result ∈ (lazyRun (auxiliary endpoint) (QueryCap.counted IsPrefixQuery middle.1.1.2) middle.2).support) :
+    queryCount middle.2 + result.1.2 ≤ budget ∧ queryCount result.2 ≤ budget := by
+  have hfull : ((result.1.1, middle.1.2 + result.1.2), result.2) ∈
+      (lazyRun (auxiliary endpoint) (QueryCap.counted IsPrefixQuery (computation endpoint)) (fun _ _ => none)).support := by
+    rw [← QueryPause.counted_resume stop step IsPrefixQuery (computation endpoint) memory]
+    simp only [lazyRun, simulateQ_bind, simulateQ_pure, StateT.run_bind, StateT.run_pure,
+      PMF.monad_bind_eq_bind, PMF.monad_pure_eq_pure, PMF.mem_support_bind_iff, PMF.mem_support_pure_iff]
+    exact ⟨middle, hmiddle, result, hresult, rfl⟩
+  have htotal := lazyRun_counted_le_of_real auxiliary computation cost budget hcharge hreal hsmall endpoint _ hfull
+  have hpast := lazyRun_counted_queryCount_le (auxiliary endpoint) (QueryPause.run stop step (computation endpoint) memory)
+    (fun _ _ => none) middle hmiddle
+  simp only [queryCount_empty, Nat.zero_add] at hpast
+  have hrows := lazyRun_counted_queryCount_le (auxiliary endpoint) middle.1.1.2 middle.2 result hresult
+  exact ⟨(Nat.add_le_add_right hpast _).trans htotal, hrows.trans ((Nat.add_le_add_right hpast _).trans htotal)⟩
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainAuxiliary.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainAuxiliary.lean
new file mode 100644
index 000000000..7ac3edc25
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainAuxiliary.lean
@@ -0,0 +1,47 @@
+import SphincsSecurity.Proof.Chains.AdaptiveChainEndpoint
+import SphincsSecurity.Proof.Base.QueryCap
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {State AuxIndex ExtraIndex : Type} {auxSpec : OracleSpec AuxIndex} {extraSpec : OracleSpec ExtraIndex} {n : Nat} {Result : Type}
+
+noncomputable def extendAux (auxiliary : QueryImpl auxSpec PMF) (extra : QueryImpl extraSpec Id) : QueryImpl (auxSpec + extraSpec) PMF
+  | .inl input => auxiliary input
+  | .inr input => PMF.pure (extra input)
+
+noncomputable def eraseAux (extra : QueryImpl extraSpec Id) :
+    QueryImpl ((auxSpec + extraSpec) + PrefixSpec n State) (OracleComp (auxSpec + PrefixSpec n State))
+  | .inl (.inl input) => liftM ((auxSpec + PrefixSpec n State).query (.inl input))
+  | .inl (.inr input) => pure (extra input)
+  | .inr query => liftM ((auxSpec + PrefixSpec n State).query (.inr query))
+
+variable [Fintype State] [DecidableEq State] [Nonempty State]
+
+omit [Fintype State] [Nonempty State] in
+theorem observedRun_eraseAux (auxiliary : QueryImpl auxSpec PMF) (extra : QueryImpl extraSpec Id)
+    (tables : Fin n → State → State) (computation : OracleComp ((auxSpec + extraSpec) + PrefixSpec n State) Result)
+    (observed : Fin n → State → Option State) :
+    observedRun auxiliary tables (simulateQ (eraseAux extra) computation) observed = observedRun (extendAux auxiliary extra) tables computation observed := by
+  have himpl : (observedImpl auxiliary tables).compose (eraseAux extra) = observedImpl (extendAux auxiliary extra) tables := by
+    funext input
+    cases input with
+    | inl input =>
+        cases input with
+        | inl input => simp only [QueryImpl.apply_compose, eraseAux, simulateQ_spec_query]; rfl
+        | inr input =>
+            simp only [QueryImpl.apply_compose, eraseAux, simulateQ_pure, observedImpl, extendAux]
+            ext observed
+            simp only [StateT.run_pure, StateT.run_mk, PMF.map, PMF.pure_bind, Function.comp_def, PMF.monad_pure_eq_pure]
+    | inr query => simp only [QueryImpl.apply_compose, eraseAux, simulateQ_spec_query]; rfl
+  simp only [observedRun, ← QueryImpl.simulateQ_compose, himpl]
+
+theorem realRun_eraseAux (auxiliary : State → QueryImpl auxSpec PMF) (extra : State → QueryImpl extraSpec Id)
+    (computation : State → OracleComp ((auxSpec + extraSpec) + PrefixSpec n State) Result)
+    (observed : Fin n → State → Option State) :
+    realRun auxiliary (fun endpoint => simulateQ (eraseAux (extra endpoint)) (computation endpoint)) observed =
+      realRun (fun endpoint => extendAux (auxiliary endpoint) (extra endpoint)) computation observed := by
+  simp only [realRun, observedRun_eraseAux]
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainBudgetPotential.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainBudgetPotential.lean
new file mode 100644
index 000000000..57a28bd7c
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainBudgetPotential.lean
@@ -0,0 +1,47 @@
+import SphincsSecurity.Proof.Chains.AdaptiveChainPotential
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+  {AuxIndex : Type} {auxSpec : OracleSpec AuxIndex} {n : Nat} {Result : Type}
+
+theorem lazyRun_budget_potential_le (auxiliary : QueryImpl auxSpec PMF)
+    (potential : Nat → (Fin n → State → Option State) → ENNReal)
+    (terminal : (Fin n → State → Option State) → ENNReal) (rate : ENNReal) (limit : Nat)
+    (hterminal : ∀ budget observed, terminal observed ≤ potential budget observed)
+    (hstep : ∀ input observed budget, budget ≤ limit → (¬IsPrefixQuery input ∨ 0 < budget) →
+      (∑' result, (lazyImpl auxiliary input).run observed result *
+        potential (if IsPrefixQuery input then budget - 1 else budget) result.2) ≤
+          potential budget observed + rate * ((if IsPrefixQuery input then 1 else 0 : Nat) : ENNReal))
+    (computation : OracleComp (auxSpec + PrefixSpec n State) Result) (observed : Fin n → State → Option State)
+    (budget : Nat) (hbudget : budget ≤ limit) (hbound : computation.IsQueryBoundP IsPrefixQuery budget) :
+    (∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) observed result * terminal result.2) ≤
+      potential budget observed + rate *
+        ∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) observed result * (result.1.2 : ENNReal) := by
+  induction computation using OracleComp.inductionOn generalizing observed budget with
+  | pure result =>
+      simp only [QueryCap.counted_pure, lazyRun_pure, expectation_pure, Nat.cast_zero, mul_zero, add_zero]
+      exact hterminal budget observed
+  | query_bind input next ih =>
+      rw [isQueryBoundP_query_bind_iff] at hbound
+      have hremaining : (if IsPrefixQuery input then budget - 1 else budget) ≤ limit := by split <;> omega
+      simp only [QueryCap.counted_query_bind, bind_pure_comp, lazyRun_query_bind, lazyRun_map,
+        expectation_bind, expectation_map, Nat.cast_add, expectation_add, expectation_const]
+      calc
+        _ ≤ ∑' output, (lazyImpl auxiliary input).run observed output *
+            (potential (if IsPrefixQuery input then budget - 1 else budget) output.2 + rate *
+              ∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery (next output.1)) output.2 result * (result.1.2 : ENNReal)) :=
+          ENNReal.tsum_le_tsum fun output => mul_le_mul' le_rfl
+            (ih output.1 output.2 _ hremaining (hbound.2 output.1))
+        _ = (∑' output, (lazyImpl auxiliary input).run observed output *
+              potential (if IsPrefixQuery input then budget - 1 else budget) output.2) +
+            rate * ∑' output, (lazyImpl auxiliary input).run observed output *
+              ∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery (next output.1)) output.2 result * (result.1.2 : ENNReal) := by
+          rw [expectation_add, expectation_scale]
+        _ ≤ _ := by
+          rw [mul_add, ← add_assoc]
+          exact _root_.add_le_add (hstep input observed budget hbudget hbound.1) le_rfl
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCap.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCap.lean
new file mode 100644
index 000000000..9a103afc4
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCap.lean
@@ -0,0 +1,92 @@
+import SphincsSecurity.Proof.Chains.AdaptiveChainErasure
+import SphincsSecurity.Proof.Chains.AdaptiveChainSupport
+import SphincsSecurity.Proof.Base.QueryCapErasure
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+  {AuxIndex : Type} {auxSpec : OracleSpec AuxIndex} {n : Nat} {Result : Type}
+  (auxiliary : State → QueryImpl auxSpec PMF)
+  (computation : State → OracleComp (auxSpec + PrefixSpec n State) Result)
+  (cost : Result → Nat) (budget : Nat)
+  (hcharge : ∀ endpoint result, result ∈ support (QueryCap.counted IsPrefixQuery (computation endpoint)) →
+    result.2 ≤ cost result.1)
+  (hreal : ∀ result ∈ (realRun auxiliary computation (fun _ _ => none)).support, cost result.2.1 ≤ budget)
+
+include hcharge hreal
+
+theorem fixed_counted_le (tables : Fin n → State → State) (secret : State) (result : Result × Nat)
+    (hresult : result ∈ (simulateQ (fixedImpl (auxiliary (evaluate tables secret)) tables)
+      (QueryCap.counted IsPrefixQuery (computation (evaluate tables secret)))).support) : result.2 ≤ budget := by
+  have hcount := hcharge (evaluate tables secret) result (QueryCap.simulate_mem_support _ _ result hresult)
+  have houtput := QueryCap.counted_simulate_result_mem IsPrefixQuery _ _ result hresult
+  have hsource := realRun_empty_result_mem auxiliary computation tables secret result.1 houtput
+  rw [PMF.mem_support_map_iff] at hsource
+  obtain ⟨source, hsource, hvalue⟩ := hsource
+  exact hcount.trans (by simpa only [hvalue] using hreal source hsource)
+
+theorem realRun_cap_erased :
+    (realRun auxiliary (fun endpoint => QueryCap.run IsPrefixQuery (computation endpoint) budget) (fun _ _ => none)).map
+      (fun result => Option.map Prod.fst result.2.1) =
+      (realRun auxiliary computation (fun _ _ => none)).map (fun result => some result.2.1) := by
+  change (realRun auxiliary (fun endpoint => QueryCap.run IsPrefixQuery (computation endpoint) budget) (fun _ _ => none)).map
+    (Option.map Prod.fst ∘ (fun result => result.2.1)) =
+    (realRun auxiliary computation (fun _ _ => none)).map (some ∘ (fun result => result.2.1))
+  rw [← PMF.map_comp, ← PMF.map_comp, realRun_empty_forget, realRun_empty_forget]
+  simp only [PMF.map_bind]
+  apply congrArg (PMF.uniformOfFintype (Fin n → State → State)).bind
+  funext tables
+  apply congrArg (PMF.uniformOfFintype State).bind
+  funext secret
+  exact QueryCap.run_erased IsPrefixQuery _ _ budget
+    (fixed_counted_le auxiliary computation cost budget hcharge hreal tables secret)
+
+theorem realRun_cap_recover_count :
+    (realRun auxiliary (fun endpoint => QueryCap.run IsPrefixQuery (computation endpoint) budget) (fun _ _ => none)).map
+      (fun result => Option.map (fun finished => (finished.1, budget - finished.2)) result.2.1) =
+      (realRun auxiliary (fun endpoint => QueryCap.counted IsPrefixQuery (computation endpoint)) (fun _ _ => none)).map
+        (fun result => some result.2.1) := by
+  change (realRun auxiliary (fun endpoint => QueryCap.run IsPrefixQuery (computation endpoint) budget) (fun _ _ => none)).map
+    (Option.map (fun finished => (finished.1, budget - finished.2)) ∘ (fun result => result.2.1)) =
+    (realRun auxiliary (fun endpoint => QueryCap.counted IsPrefixQuery (computation endpoint)) (fun _ _ => none)).map
+      (some ∘ (fun result => result.2.1))
+  rw [← PMF.map_comp, ← PMF.map_comp, realRun_empty_forget, realRun_empty_forget]
+  simp only [PMF.map_bind]
+  apply congrArg (PMF.uniformOfFintype (Fin n → State → State)).bind
+  funext tables
+  apply congrArg (PMF.uniformOfFintype State).bind
+  funext secret
+  exact QueryCap.run_recover_count IsPrefixQuery _ _ budget
+    (fixed_counted_le auxiliary computation cost budget hcharge hreal tables secret)
+
+theorem realRun_cap_valid (result : State × (Option (Result × Nat) × (Fin n → State → Option State)))
+    (hresult : result ∈ (realRun auxiliary (fun endpoint => QueryCap.run IsPrefixQuery (computation endpoint) budget)
+      (fun _ _ => none)).support) :
+    ∃ finished, result.2.1 = some finished ∧ cost finished.1 ≤ budget := by
+  have hmap : Option.map Prod.fst result.2.1 ∈
+      ((realRun auxiliary (fun endpoint => QueryCap.run IsPrefixQuery (computation endpoint) budget) (fun _ _ => none)).map
+        (fun result => Option.map Prod.fst result.2.1)).support := by
+    rw [PMF.mem_support_map_iff]
+    exact ⟨result, hresult, rfl⟩
+  rw [realRun_cap_erased auxiliary computation cost budget hcharge hreal, PMF.mem_support_map_iff] at hmap
+  obtain ⟨source, hsource, hvalue⟩ := hmap
+  cases hfinished : result.2.1 with
+  | none => simp only [hfinished, Option.map_none, Option.some_ne_none] at hvalue
+  | some finished =>
+      refine ⟨finished, rfl, ?_⟩
+      have heq : source.2.1 = finished.1 := by simpa only [hfinished, Option.map_some, Option.some.injEq] using hvalue
+      rw [← heq]
+      exact hreal source hsource
+
+theorem idealRun_cap_valid (hsmall : budget < Fintype.card State)
+    (result : State × (Option (Result × Nat) × (Fin n → State → Option State)))
+    (hresult : result ∈ (idealRun auxiliary (fun endpoint => QueryCap.run IsPrefixQuery (computation endpoint) budget)
+      (fun _ _ => none)).support) :
+    ∃ finished, result.2.1 = some finished ∧ cost finished.1 ≤ budget := by
+  apply realRun_cap_valid auxiliary computation cost budget hcharge hreal result
+  exact idealRun_empty_support_subset auxiliary _ budget
+    (fun endpoint => QueryCap.run_queryBound IsPrefixQuery (computation endpoint) budget) hsmall hresult
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCapContact.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCapContact.lean
new file mode 100644
index 000000000..96691985a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCapContact.lean
@@ -0,0 +1,105 @@
+import SphincsSecurity.Proof.Chains.AdaptiveChainContact
+import SphincsSecurity.Proof.Chains.AdaptiveChainCapCost
+import SphincsSecurity.Proof.Base.QueryCapBalance
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+  {AuxIndex : Type} {auxSpec : OracleSpec AuxIndex} {n : Nat} {Result Next : Type}
+
+theorem lazyRun_result_mem (auxiliary : QueryImpl auxSpec PMF)
+    (computation : OracleComp (auxSpec + PrefixSpec n State) Result) (observed : Fin n → State → Option State)
+    (result : Result × (Fin n → State → Option State)) (hresult : result ∈ (lazyRun auxiliary computation observed).support) :
+    result.1 ∈ support computation := by
+  induction computation using OracleComp.inductionOn generalizing observed with
+  | pure value =>
+      rw [lazyRun_pure, PMF.mem_support_pure_iff] at hresult
+      subst result
+      exact (mem_support_pure_iff _ _).mpr rfl
+  | query_bind input next ih =>
+      rw [lazyRun_query_bind, PMF.mem_support_bind_iff] at hresult
+      obtain ⟨middle, _, hresult⟩ := hresult
+      rw [mem_support_bind_iff]
+      exact ⟨middle.1, by simp only [support_query, Set.mem_univ], ih middle.1 middle.2 hresult⟩
+
+theorem idealRun_result_mem (auxiliary : State → QueryImpl auxSpec PMF)
+    (computation : State → OracleComp (auxSpec + PrefixSpec n State) Result) (observed : Fin n → State → Option State)
+    (result : State × (Result × (Fin n → State → Option State))) (hresult : result ∈ (idealRun auxiliary computation observed).support) :
+    result.2.1 ∈ support (computation result.1) := by
+  rw [idealRun, PMF.mem_support_bind_iff] at hresult
+  obtain ⟨endpoint, _, hresult⟩ := hresult
+  rw [PMF.mem_support_map_iff] at hresult
+  obtain ⟨output, houtput, rfl⟩ := hresult
+  exact lazyRun_result_mem (auxiliary endpoint) (computation endpoint) observed output houtput
+
+theorem idealRun_map (auxiliary : State → QueryImpl auxSpec PMF)
+    (computation : State → OracleComp (auxSpec + PrefixSpec n State) Result) (f : State → Result → Next)
+    (observed : Fin n → State → Option State) :
+    idealRun auxiliary (fun endpoint => f endpoint <$> computation endpoint) observed =
+      (idealRun auxiliary computation observed).map (fun result => (result.1, f result.1 result.2.1, result.2.2)) := by
+  simp only [idealRun, lazyRun_map, PMF.map_bind, PMF.map_comp, Function.comp_def]
+
+theorem idealRun_counted_forget (auxiliary : State → QueryImpl auxSpec PMF)
+    (computation : State → OracleComp (auxSpec + PrefixSpec n State) Result) (observed : Fin n → State → Option State) :
+    (idealRun auxiliary (fun endpoint => QueryCap.counted IsPrefixQuery (computation endpoint)) observed).map
+      (fun result => (result.1, result.2.1.1, result.2.2)) = idealRun auxiliary computation observed := by
+  simpa only [QueryCap.counted_forget] using
+    (idealRun_map auxiliary (fun endpoint => QueryCap.counted IsPrefixQuery (computation endpoint)) (fun _ => Prod.fst) observed).symm
+
+variable (auxiliary : State → QueryImpl auxSpec PMF)
+  (computation : State → OracleComp (auxSpec + PrefixSpec n State) Result)
+  (cost : Result → Nat) (budget : Nat)
+  (hcharge : ∀ endpoint result, result ∈ support (QueryCap.counted IsPrefixQuery (computation endpoint)) →
+    result.2 ≤ cost result.1)
+  (hreal : ∀ result ∈ (realRun auxiliary computation (fun _ _ => none)).support, cost result.2.1 ≤ budget)
+  (hsmall : budget < Fintype.card State)
+
+include hcharge hreal hsmall
+
+theorem idealRun_counted_cap_spent
+    (result : State × ((Option (Result × Nat) × Nat) × (Fin n → State → Option State)))
+    (hresult : result ∈ (idealRun auxiliary
+      (fun endpoint => QueryCap.counted IsPrefixQuery (QueryCap.run IsPrefixQuery (computation endpoint) budget)) (fun _ _ => none)).support) :
+    result.2.1.2 = QueryCap.spent budget result.2.1.1 := by
+  have hforget : (result.1, result.2.1.1, result.2.2) ∈
+      (idealRun auxiliary (fun endpoint => QueryCap.run IsPrefixQuery (computation endpoint) budget) (fun _ _ => none)).support := by
+    rw [← idealRun_counted_forget auxiliary (fun endpoint => QueryCap.run IsPrefixQuery (computation endpoint) budget) (fun _ _ => none),
+      PMF.mem_support_map_iff]
+    exact ⟨result, hresult, rfl⟩
+  obtain ⟨finished, hfinished, _⟩ := idealRun_cap_valid auxiliary computation cost budget hcharge hreal hsmall _ hforget
+  change result.2.1.1 = some finished at hfinished
+  have hbalance := QueryCap.counted_run_balance IsPrefixQuery (computation result.1) budget result.2.1
+    (idealRun_result_mem auxiliary _ (fun _ _ => none) result hresult)
+  simp only [hfinished, Option.elim_some] at hbalance
+  simp only [QueryCap.spent, hfinished, Option.elim_some]
+  omega
+
+theorem idealRun_cap_count_expectation :
+    (∑' result, idealRun auxiliary
+        (fun endpoint => QueryCap.counted IsPrefixQuery (QueryCap.run IsPrefixQuery (computation endpoint) budget)) (fun _ _ => none) result *
+          (result.2.1.2 : ENNReal)) =
+      ∑' result, idealRun auxiliary (fun endpoint => QueryCap.run IsPrefixQuery (computation endpoint) budget) (fun _ _ => none) result *
+        (QueryCap.spent budget result.2.1 : ENNReal) := by
+  rw [← idealRun_counted_forget auxiliary (fun endpoint => QueryCap.run IsPrefixQuery (computation endpoint) budget) (fun _ _ => none), expectation_map]
+  apply tsum_congr
+  intro result
+  by_cases hresult : result ∈ (idealRun auxiliary
+      (fun endpoint => QueryCap.counted IsPrefixQuery (QueryCap.run IsPrefixQuery (computation endpoint) budget)) (fun _ _ => none)).support
+  · rw [idealRun_counted_cap_spent auxiliary computation cost budget hcharge hreal hsmall result hresult]
+  · have hzero : idealRun auxiliary
+        (fun endpoint => QueryCap.counted IsPrefixQuery (QueryCap.run IsPrefixQuery (computation endpoint) budget)) (fun _ _ => none) result = 0 :=
+      not_not.mp hresult
+    simp only [hzero, zero_mul]
+
+theorem realRun_cap_contact_le :
+    Pr[fun result => Contact result.2.2 result.1 |
+      realRun auxiliary (fun endpoint => QueryCap.run IsPrefixQuery (computation endpoint) budget) (fun _ _ => none)] ≤
+        (2 / Fintype.card State) * ∑' result,
+          idealRun auxiliary (fun endpoint => QueryCap.run IsPrefixQuery (computation endpoint) budget) (fun _ _ => none) result *
+            (QueryCap.spent budget result.2.1 : ENNReal) := by
+  have h := realRun_contact_le auxiliary (fun endpoint => QueryCap.run IsPrefixQuery (computation endpoint) budget)
+  rwa [idealRun_cap_count_expectation auxiliary computation cost budget hcharge hreal hsmall] at h
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCapCost.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCapCost.lean
new file mode 100644
index 000000000..b36a94dd1
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCapCost.lean
@@ -0,0 +1,68 @@
+import SphincsSecurity.Proof.Chains.AdaptiveChainCap
+namespace SphincsSecurity.QueryCap
+
+open _root_.OracleComp OracleSpec ENNReal
+
+def spent {Result : Type} (budget : Nat) (result : Option (Result × Nat)) : Nat :=
+  result.elim 0 (fun finished => budget - finished.2)
+
+theorem scaled_expectation_bind_le {Sample First Second : Type} (prior : SPMF Sample)
+    (first : Sample → SPMF First) (second : Sample → SPMF Second)
+    (firstCost : First → ENNReal) (secondCost : Second → ENNReal) (factor : ENNReal)
+    (h : ∀ sample ∈ support prior,
+      factor * (∑' result, Pr[= result | first sample] * firstCost result) ≤
+        ∑' result, Pr[= result | second sample] * secondCost result) :
+    factor * (∑' result, Pr[= result | prior >>= first] * firstCost result) ≤
+      ∑' result, Pr[= result | prior >>= second] * secondCost result := by
+  rw [tsum_probOutput_bind_mul, tsum_probOutput_bind_mul, ← ENNReal.tsum_mul_left]
+  apply ENNReal.tsum_le_tsum
+  intro sample
+  by_cases hsample : sample ∈ support prior
+  · rw [mul_left_comm factor]
+    exact mul_le_mul' le_rfl (h sample hsample)
+  · rw [probOutput_eq_zero_of_not_mem_support hsample, zero_mul, zero_mul, mul_zero]
+
+end SphincsSecurity.QueryCap
+
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec ENNReal
+set_option backward.isDefEq.respectTransparency false
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+  {AuxIndex : Type} {auxSpec : OracleSpec AuxIndex} {n : Nat} {Result : Type}
+  (auxiliary : State → QueryImpl auxSpec PMF)
+  (computation : State → OracleComp (auxSpec + PrefixSpec n State) Result)
+  (cost : Result → Nat) (budget : Nat)
+  (hcharge : ∀ endpoint result, result ∈ support (QueryCap.counted IsPrefixQuery (computation endpoint)) →
+    result.2 ≤ cost result.1)
+  (hreal : ∀ result ∈ (realRun auxiliary computation (fun _ _ => none)).support, cost result.2.1 ≤ budget)
+
+include hcharge hreal
+
+theorem realRun_cap_count_payoff (payoff : Result × Nat → ENNReal) :
+    (∑' result, realRun auxiliary (fun endpoint => QueryCap.run IsPrefixQuery (computation endpoint) budget)
+        (fun _ _ => none) result * result.2.1.elim 0 (fun finished => payoff (finished.1, budget - finished.2))) =
+      ∑' result, realRun auxiliary (fun endpoint => QueryCap.counted IsPrefixQuery (computation endpoint))
+        (fun _ _ => none) result * payoff result.2.1 := by
+  have h := congrArg (fun law : PMF (Option (Result × Nat)) => ∑' result, law result * result.elim 0 payoff)
+    (realRun_cap_recover_count auxiliary computation cost budget hcharge hreal)
+  simpa only [expectation_map, Option.elim_map, Option.elim_some, Function.comp_def] using h
+
+theorem idealRun_cap_spent_lower :
+    (1 - (budget : ENNReal) / Fintype.card State) *
+        (∑' result, idealRun auxiliary (fun endpoint => QueryCap.run IsPrefixQuery (computation endpoint) budget)
+          (fun _ _ => none) result * (QueryCap.spent budget result.2.1 : ENNReal)) ≤
+      ∑' result, realRun auxiliary (fun endpoint => QueryCap.counted IsPrefixQuery (computation endpoint))
+        (fun _ _ => none) result * (result.2.1.2 : ENNReal) := by
+  apply (realRun_empty_cost_lower auxiliary (fun endpoint => QueryCap.run IsPrefixQuery (computation endpoint) budget)
+    budget (fun endpoint => QueryCap.run_queryBound IsPrefixQuery (computation endpoint) budget)
+    (fun result => (QueryCap.spent budget result.2.1 : ENNReal))).trans_eq
+  have h := realRun_cap_count_payoff auxiliary computation cost budget hcharge hreal (fun result => (result.2 : ENNReal))
+  convert h using 1
+  apply tsum_congr
+  intro result
+  congr 1
+  cases result.2.1 <;> simp only [QueryCap.spent, Option.elim_none, Option.elim_some, Nat.cast_zero]
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCapObservation.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCapObservation.lean
new file mode 100644
index 000000000..3bb47395f
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCapObservation.lean
@@ -0,0 +1,137 @@
+import SphincsSecurity.Proof.Chains.AdaptiveChainCapContact
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+private theorem pmf_bind_eq_on_support {First Second : Type} (prior : PMF First) (first second : First → PMF Second)
+    (h : ∀ input ∈ prior.support, first input = second input) : prior.bind first = prior.bind second := by
+  apply PMF.ext
+  intro result
+  simp only [PMF.bind_apply]
+  apply tsum_congr
+  intro input
+  by_cases hi : input ∈ prior.support
+  · rw [h input hi]
+  · have hz : prior input = 0 := not_not.mp hi
+    simp only [hz, zero_mul]
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+  {AuxIndex : Type} {auxSpec : OracleSpec AuxIndex} {n : Nat} {Result Next : Type}
+
+omit [Fintype State] [Nonempty State] in
+theorem observedRun_map (auxiliary : QueryImpl auxSpec PMF) (tables : Fin n → State → State)
+    (computation : OracleComp (auxSpec + PrefixSpec n State) Result) (f : Result → Next)
+    (observed : Fin n → State → Option State) :
+    observedRun auxiliary tables (f <$> computation) observed =
+      (observedRun auxiliary tables computation observed).map (fun result => (f result.1, result.2)) := by
+  simp only [observedRun, simulateQ_map, StateT.run_map, PMF.monad_map_eq_map]
+
+omit [Fintype State] [Nonempty State] in
+theorem observedRun_cap_eq_counted (auxiliary : QueryImpl auxSpec PMF) (tables : Fin n → State → State)
+    (computation : OracleComp (auxSpec + PrefixSpec n State) Result) (observed : Fin n → State → Option State) (budget : Nat)
+    (hbound : ∀ result ∈ (simulateQ (fixedImpl auxiliary tables) (QueryCap.counted IsPrefixQuery computation)).support,
+      result.2 ≤ budget) :
+    observedRun auxiliary tables (QueryCap.run IsPrefixQuery computation budget) observed =
+      (observedRun auxiliary tables (QueryCap.counted IsPrefixQuery computation) observed).map
+        (fun result => (some (result.1.1, budget - result.1.2), result.2)) := by
+  induction computation using OracleComp.inductionOn generalizing observed budget with
+  | pure value =>
+      simp only [QueryCap.run_pure, QueryCap.counted_pure, observedRun_pure, PMF.map, PMF.pure_bind, Function.comp_def, Nat.sub_zero]
+  | query_bind input next ih =>
+      rw [QueryCap.run_query_bind, QueryCap.counted_query_bind]
+      simp only [bind_pure_comp, observedRun_query_bind, observedRun_map]
+      cases input with
+      | inl input =>
+          simp only [IsPrefixQuery, if_false, observedRun_query_bind, observedImpl, StateT.run_mk,
+            PMF.bind_map, PMF.map_bind, PMF.map_comp, Function.comp_def, Nat.zero_add]
+          apply pmf_bind_eq_on_support
+          intro answer hanswer
+          apply ih answer observed budget
+          intro tail htail
+          have h := QueryCap.counted_next_bound IsPrefixQuery (fixedImpl auxiliary tables) (.inl input) next budget hbound answer hanswer tail htail
+          simpa only [IsPrefixQuery, if_false, Nat.zero_add] using h
+      | inr query =>
+          simp only [IsPrefixQuery, if_true]
+          have hnext := fun tail htail => QueryCap.counted_next_bound IsPrefixQuery (fixedImpl auxiliary tables)
+            (.inr query) next budget hbound (tables query.1 query.2) (by simp [fixedImpl]) tail htail
+          cases budget with
+          | zero =>
+              obtain ⟨tail, htail⟩ := (simulateQ (fixedImpl auxiliary tables)
+                (QueryCap.counted IsPrefixQuery (next (tables query.1 query.2)))).support_nonempty
+              have h := hnext tail htail
+              simp only [IsPrefixQuery, if_true] at h
+              omega
+          | succ budget =>
+              simp only [observedRun_query_bind, observedImpl, StateT.run_mk, PMF.pure_bind,
+                PMF.map_comp, Function.comp_def, Nat.add_comm 1, Nat.add_sub_add_right]
+              apply ih (tables query.1 query.2) (record observed query (tables query.1 query.2)) budget
+              intro tail htail
+              have h := hnext tail htail
+              simp only [IsPrefixQuery, if_true] at h
+              omega
+
+theorem realRun_map (auxiliary : State → QueryImpl auxSpec PMF)
+    (computation : State → OracleComp (auxSpec + PrefixSpec n State) Result) (f : State → Result → Next)
+    (observed : Fin n → State → Option State) :
+    realRun auxiliary (fun endpoint => f endpoint <$> computation endpoint) observed =
+      (realRun auxiliary computation observed).map (fun result => (result.1, f result.1 result.2.1, result.2.2)) := by
+  simp only [realRun, observedRun_map, PMF.map_bind, PMF.map_comp, Function.comp_def]
+
+theorem realRun_counted_forget (auxiliary : State → QueryImpl auxSpec PMF)
+    (computation : State → OracleComp (auxSpec + PrefixSpec n State) Result) (observed : Fin n → State → Option State) :
+    (realRun auxiliary (fun endpoint => QueryCap.counted IsPrefixQuery (computation endpoint)) observed).map
+      (fun result => (result.1, result.2.1.1, result.2.2)) = realRun auxiliary computation observed := by
+  simpa only [QueryCap.counted_forget] using
+    (realRun_map auxiliary (fun endpoint => QueryCap.counted IsPrefixQuery (computation endpoint)) (fun _ => Prod.fst) observed).symm
+
+variable (auxiliary : State → QueryImpl auxSpec PMF)
+  (computation : State → OracleComp (auxSpec + PrefixSpec n State) Result)
+  (cost : Result → Nat) (budget : Nat)
+  (hcharge : ∀ endpoint result, result ∈ support (QueryCap.counted IsPrefixQuery (computation endpoint)) →
+    result.2 ≤ cost result.1)
+  (hreal : ∀ result ∈ (realRun auxiliary computation (fun _ _ => none)).support, cost result.2.1 ≤ budget)
+
+include hcharge hreal
+
+theorem realRun_cap_eq_counted_observed :
+    realRun auxiliary (fun endpoint => QueryCap.run IsPrefixQuery (computation endpoint) budget) (fun _ _ => none) =
+      (realRun auxiliary (fun endpoint => QueryCap.counted IsPrefixQuery (computation endpoint)) (fun _ _ => none)).map
+        (fun result => (result.1, some (result.2.1.1, budget - result.2.1.2), result.2.2)) := by
+  simp only [realRun, completeTables_empty, EndpointPreimageDensity.real, PMF.map_bind, PMF.bind_bind, PMF.bind_map,
+    PMF.map_comp, Function.comp_def]
+  apply congrArg (PMF.uniformOfFintype (Fin n → State → State)).bind
+  funext tables
+  apply congrArg (PMF.uniformOfFintype State).bind
+  funext secret
+  rw [observedRun_cap_eq_counted (auxiliary (evaluate tables secret)) tables (computation (evaluate tables secret))
+    (fun _ _ => none) budget (fixed_counted_le auxiliary computation cost budget hcharge hreal tables secret), PMF.map_comp]
+  simp only [Function.comp_def]
+
+theorem realRun_cap_erased_observed :
+    (realRun auxiliary (fun endpoint => QueryCap.run IsPrefixQuery (computation endpoint) budget) (fun _ _ => none)).map
+      (fun result => (result.1, Option.map Prod.fst result.2.1, result.2.2)) =
+      (realRun auxiliary computation (fun _ _ => none)).map (fun result => (result.1, some result.2.1, result.2.2)) := by
+  rw [realRun_cap_eq_counted_observed auxiliary computation cost budget hcharge hreal, PMF.map_comp]
+  have h := congrArg (PMF.map (fun result : State × (Result × (Fin n → State → Option State)) =>
+    (result.1, some result.2.1, result.2.2))) (realRun_counted_forget auxiliary computation (fun _ _ => none))
+  simpa only [PMF.map_comp, Function.comp_def, Option.map_some] using h
+
+theorem realRun_cap_contact_eq :
+    Pr[fun result => Contact result.2.2 result.1 |
+      realRun auxiliary (fun endpoint => QueryCap.run IsPrefixQuery (computation endpoint) budget) (fun _ _ => none)] =
+        Pr[fun result => Contact result.2.2 result.1 | realRun auxiliary computation (fun _ _ => none)] := by
+  have h := congrArg (fun law : PMF (State × (Option Result × (Fin n → State → Option State))) =>
+    Pr[fun result => Contact result.2.2 result.1 | law])
+    (realRun_cap_erased_observed auxiliary computation cost budget hcharge hreal)
+  simpa only [← PMF.monad_map_eq_map, probEvent_map, Function.comp_def] using h
+
+theorem realRun_contact_le_cap_cost (hsmall : budget < Fintype.card State) :
+    Pr[fun result => Contact result.2.2 result.1 | realRun auxiliary computation (fun _ _ => none)] ≤
+      (2 / Fintype.card State) * ∑' result,
+        idealRun auxiliary (fun endpoint => QueryCap.run IsPrefixQuery (computation endpoint) budget) (fun _ _ => none) result *
+          (QueryCap.spent budget result.2.1 : ENNReal) := by
+  rw [← realRun_cap_contact_eq auxiliary computation cost budget hcharge hreal]
+  exact realRun_cap_contact_le auxiliary computation cost budget hcharge hreal hsmall
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCapTwoEdge.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCapTwoEdge.lean
new file mode 100644
index 000000000..783d6395f
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCapTwoEdge.lean
@@ -0,0 +1,66 @@
+import SphincsSecurity.Proof.Chains.AdaptiveChainTwoEdge
+import SphincsSecurity.Proof.Chains.AdaptiveChainCapObservation
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+  {AuxIndex : Type} {auxSpec : OracleSpec AuxIndex} {n : Nat} {Result : Type}
+  (auxiliary : State → QueryImpl auxSpec PMF)
+  (computation : State → OracleComp (auxSpec + PrefixSpec (n + 2) State) Result)
+  (cost : Result → Nat) (budget : Nat)
+  (hcharge : ∀ endpoint result, result ∈ support (QueryCap.counted IsPrefixQuery (computation endpoint)) →
+    result.2 ≤ cost result.1)
+  (hreal : ∀ result ∈ (realRun auxiliary computation (fun _ _ => none)).support, cost result.2.1 ≤ budget)
+
+include hcharge hreal
+
+theorem realRun_cap_twoEdge_eq :
+    Pr[fun result => TwoEdge result.2.2 result.1 |
+      realRun auxiliary (fun endpoint => QueryCap.run IsPrefixQuery (computation endpoint) budget) (fun _ _ => none)] =
+        Pr[fun result => TwoEdge result.2.2 result.1 | realRun auxiliary computation (fun _ _ => none)] := by
+  have h := congrArg (fun law : PMF (State × (Option Result × (Fin (n + 2) → State → Option State))) =>
+    Pr[fun result => TwoEdge result.2.2 result.1 | law])
+    (realRun_cap_erased_observed auxiliary computation cost budget hcharge hreal)
+  simpa only [← PMF.monad_map_eq_map, probEvent_map, Function.comp_def] using h
+
+theorem realRun_twoEdge_le_cap_cost (hsmall : budget < Fintype.card State) :
+    Pr[fun result => TwoEdge result.2.2 result.1 | realRun auxiliary computation (fun _ _ => none)] ≤
+      (((3 / 2 : ENNReal) + 4 * ((budget : ENNReal) / Fintype.card State) +
+        2 * ((budget : ENNReal) / Fintype.card State)^2) / Fintype.card State) *
+          ∑' result, idealRun auxiliary (fun endpoint => QueryCap.run IsPrefixQuery (computation endpoint) budget)
+            (fun _ _ => none) result * (QueryCap.spent budget result.2.1 : ENNReal) := by
+  rw [← realRun_cap_twoEdge_eq auxiliary computation cost budget hcharge hreal]
+  have h := realRun_twoEdge_le auxiliary (fun endpoint => QueryCap.run IsPrefixQuery (computation endpoint) budget)
+    budget (fun endpoint => QueryCap.run_queryBound IsPrefixQuery (computation endpoint) budget)
+  rw [idealRun_cap_count_expectation auxiliary computation cost budget hcharge hreal hsmall] at h
+  exact h
+
+omit hcharge hreal in
+def TwoEdgeEvent : {depth : Nat} → (Fin depth → State → Option State) → State → Prop
+  | 0, _, _ => False
+  | 1, _, _ => False
+  | _ + 2, observed, endpoint => TwoEdge observed endpoint
+
+omit hcharge hreal in
+theorem realRun_twoEdgeEvent_le_cap_cost {depth : Nat} (auxiliary : State → QueryImpl auxSpec PMF)
+    (computation : State → OracleComp (auxSpec + PrefixSpec depth State) Result)
+    (cost : Result → Nat) (budget : Nat)
+    (hcharge : ∀ endpoint result, result ∈ support (QueryCap.counted IsPrefixQuery (computation endpoint)) →
+      result.2 ≤ cost result.1)
+    (hreal : ∀ result ∈ (realRun auxiliary computation (fun _ _ => none)).support, cost result.2.1 ≤ budget)
+    (hsmall : budget < Fintype.card State) :
+    Pr[fun result => TwoEdgeEvent result.2.2 result.1 | realRun auxiliary computation (fun _ _ => none)] ≤
+      (((3 / 2 : ENNReal) + 4 * ((budget : ENNReal) / Fintype.card State) +
+        2 * ((budget : ENNReal) / Fintype.card State)^2) / Fintype.card State) *
+          ∑' result, idealRun auxiliary (fun endpoint => QueryCap.run IsPrefixQuery (computation endpoint) budget)
+            (fun _ _ => none) result * (QueryCap.spent budget result.2.1 : ENNReal) := by
+  cases depth with
+  | zero => simp only [TwoEdgeEvent, probEvent_eq_tsum_ite, if_false, tsum_zero]; exact bot_le
+  | succ depth =>
+      cases depth with
+      | zero => simp only [TwoEdgeEvent, probEvent_eq_tsum_ite, if_false, tsum_zero]; exact bot_le
+      | succ depth => exact realRun_twoEdge_le_cap_cost auxiliary computation cost budget hcharge hreal hsmall
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCheckpoint.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCheckpoint.lean
new file mode 100644
index 000000000..9a988e916
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCheckpoint.lean
@@ -0,0 +1,152 @@
+import SphincsSecurity.Proof.Chains.AdaptiveChainRestart
+import SphincsSecurity.Proof.Chains.AdaptiveChainCountedRows
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+  {AuxIndex : Type} {auxSpec : OracleSpec AuxIndex} {n : Nat} {Checkpoint Result : Type}
+
+theorem run_posterior_payoff (auxiliary : QueryImpl auxSpec PMF)
+    (computation : OracleComp (auxSpec + PrefixSpec n State) Result) (observed : Fin n → State → Option State)
+    (payoff : (Fin n → State → State) → Result × (Fin n → State → Option State) → ENNReal) :
+    (∑' tables, completeTables observed tables *
+      ∑' result, observedRun auxiliary tables computation observed result * payoff tables result) =
+    ∑' result, lazyRun auxiliary computation observed result *
+      ∑' tables, completeTables result.2 tables * payoff tables result := by
+  have h := congrArg (fun law : PMF ((Fin n → State → State) × (Result × (Fin n → State → Option State))) =>
+    ∑' result, law result * payoff result.1 result.2) (run_posterior auxiliary computation observed)
+  simpa only [expectation_bind, expectation_map] using h
+
+theorem observedRun_supported_completion (auxiliary : QueryImpl auxSpec PMF)
+    (computation : OracleComp (auxSpec + PrefixSpec n State) Result) (observed : Fin n → State → Option State)
+    (tables : Fin n → State → State) (htables : tables ∈ (completeTables observed).support)
+    (result : Result × (Fin n → State → Option State)) (hresult : result ∈ (observedRun auxiliary tables computation observed).support) :
+    result ∈ (lazyRun auxiliary computation observed).support ∧ tables ∈ (completeTables result.2).support := by
+  have hpair : (tables, result) ∈ ((completeTables observed).bind fun tables =>
+      (observedRun auxiliary tables computation observed).map fun result => (tables, result)).support := by
+    rw [PMF.mem_support_bind_iff]
+    refine ⟨tables, htables, ?_⟩
+    rw [PMF.mem_support_map_iff]
+    exact ⟨result, hresult, rfl⟩
+  rw [run_posterior, PMF.mem_support_bind_iff] at hpair
+  obtain ⟨middle, hmiddle, hpair⟩ := hpair
+  rw [PMF.mem_support_map_iff] at hpair
+  obtain ⟨completed, hcompleted, heq⟩ := hpair
+  simp only [Prod.mk.injEq] at heq
+  rcases heq with ⟨rfl, rfl⟩
+  exact ⟨hmiddle, hcompleted⟩
+
+theorem realRun_support_lazy (auxiliary : State → QueryImpl auxSpec PMF)
+    (computation : State → OracleComp (auxSpec + PrefixSpec n State) Result)
+    (observed : Fin n → State → Option State) (result : State × (Result × (Fin n → State → Option State)))
+    (hr : result ∈ (realRun auxiliary computation observed).support) :
+    result.2 ∈ (lazyRun (auxiliary result.1) (computation result.1) observed).support := by
+  rw [realRun, PMF.mem_support_bind_iff] at hr
+  obtain ⟨⟨tables, endpoint⟩, hsource, hr⟩ := hr
+  rw [PMF.mem_support_map_iff] at hr
+  obtain ⟨output, ho, rfl⟩ := hr
+  have ht : tables ∈ (completeTables observed).support := by
+    intro hz
+    apply hsource
+    simp only [EndpointPreimageDensity.real_apply, hz, zero_mul]
+  exact (observedRun_supported_completion (auxiliary endpoint) (computation endpoint) observed tables ht output ho).1
+
+noncomputable def checkpointObservedRun (auxiliary : QueryImpl auxSpec PMF) (tables : Fin n → State → State)
+    (before : OracleComp (auxSpec + PrefixSpec n State) Checkpoint)
+    (after : Checkpoint × (Fin n → State → Option State) → OracleComp (auxSpec + PrefixSpec n State) Result)
+    (observed : Fin n → State → Option State) :
+    PMF ((Checkpoint × (Fin n → State → Option State)) × ((Result × Nat) × (Fin n → State → Option State))) :=
+  (observedRun auxiliary tables before observed).bind fun middle =>
+    (observedRun auxiliary tables (QueryCap.counted IsPrefixQuery (after middle)) middle.2).map fun result => (middle, result)
+
+noncomputable def realCheckpointRun (auxiliary : State → QueryImpl auxSpec PMF)
+    (before : State → OracleComp (auxSpec + PrefixSpec n State) Checkpoint)
+    (after : State → Checkpoint × (Fin n → State → Option State) → OracleComp (auxSpec + PrefixSpec n State) Result)
+    (observed : Fin n → State → Option State) :
+    PMF (State × (Checkpoint × (Fin n → State → Option State)) × ((Result × Nat) × (Fin n → State → Option State))) :=
+  (EndpointPreimageDensity.real (completeTables observed) evaluate).bind fun pair =>
+    (checkpointObservedRun (auxiliary pair.2) pair.1 (before pair.2) (after pair.2) observed).map fun result => (pair.2, result)
+
+theorem realCheckpointRun_support (auxiliary : State → QueryImpl auxSpec PMF)
+    (before : State → OracleComp (auxSpec + PrefixSpec n State) Checkpoint)
+    (after : State → Checkpoint × (Fin n → State → Option State) → OracleComp (auxSpec + PrefixSpec n State) Result)
+    (observed : Fin n → State → Option State)
+    (result : State × (Checkpoint × (Fin n → State → Option State)) × ((Result × Nat) × (Fin n → State → Option State)))
+    (hresult : result ∈ (realCheckpointRun auxiliary before after observed).support) :
+    result.2.1 ∈ (lazyRun (auxiliary result.1) (before result.1) observed).support ∧
+      result.2.2 ∈ (lazyRun (auxiliary result.1) (QueryCap.counted IsPrefixQuery (after result.1 result.2.1)) result.2.1.2).support := by
+  classical
+  rw [realCheckpointRun, PMF.mem_support_bind_iff] at hresult
+  obtain ⟨⟨tables, endpoint⟩, hsource, hresult⟩ := hresult
+  rw [PMF.mem_support_map_iff] at hresult
+  obtain ⟨pair, hpair, rfl⟩ := hresult
+  rw [checkpointObservedRun, PMF.mem_support_bind_iff] at hpair
+  obtain ⟨middle, hmiddle, hpair⟩ := hpair
+  rw [PMF.mem_support_map_iff] at hpair
+  obtain ⟨final, hfinal, rfl⟩ := hpair
+  have ht : tables ∈ (completeTables observed).support := by
+    intro hz
+    apply hsource
+    simp only [EndpointPreimageDensity.real_apply, hz, zero_mul]
+  have hm := observedRun_supported_completion (auxiliary endpoint) (before endpoint) observed tables ht middle hmiddle
+  exact ⟨hm.1, (observedRun_supported_completion (auxiliary endpoint) (QueryCap.counted IsPrefixQuery (after endpoint middle))
+    middle.2 tables hm.2 final hfinal).1⟩
+
+theorem realCheckpointRun_before (auxiliary : State → QueryImpl auxSpec PMF)
+    (before : State → OracleComp (auxSpec + PrefixSpec n State) Checkpoint)
+    (after : State → Checkpoint × (Fin n → State → Option State) → OracleComp (auxSpec + PrefixSpec n State) Result)
+    (observed : Fin n → State → Option State) :
+    (realCheckpointRun auxiliary before after observed).map (fun result => (result.1, result.2.1)) =
+      realRun auxiliary before observed := by
+  simp only [realCheckpointRun, checkpointObservedRun, realRun, PMF.map_bind, PMF.map_comp, Function.comp_def]
+  simp only [PMF.map, Function.comp_def, PMF.bind_const]
+
+theorem realCheckpointRun_expectation (auxiliary : State → QueryImpl auxSpec PMF)
+    (before : State → OracleComp (auxSpec + PrefixSpec n State) Checkpoint)
+    (after : State → Checkpoint × (Fin n → State → Option State) → OracleComp (auxSpec + PrefixSpec n State) Result)
+    (observed : Fin n → State → Option State)
+    (payoff : State × (Checkpoint × (Fin n → State → Option State)) × ((Result × Nat) × (Fin n → State → Option State)) → ENNReal) :
+    (∑' result, realCheckpointRun auxiliary before after observed result * payoff result) =
+    ∑' endpoint, PMF.uniformOfFintype State endpoint * ∑' middle, lazyRun (auxiliary endpoint) (before endpoint) observed middle *
+      ∑' tables, completeTables middle.2 tables *
+        ∑' result, observedRun (auxiliary endpoint) tables (QueryCap.counted IsPrefixQuery (after endpoint middle)) middle.2 result *
+          ((EndpointPreimageDensity.preimages evaluate tables endpoint : ENNReal) * payoff (endpoint, middle, result)) := by
+  classical
+  simp only [realCheckpointRun, expectation_bind, expectation_map]
+  rw [EndpointPreimageDensity.real_payoff, ENNReal.tsum_prod', ENNReal.tsum_comm]
+  simp only [EndpointPreimageDensity.ideal_apply, div_eq_mul_inv, PMF.uniformOfFintype_apply,
+    checkpointObservedRun, expectation_bind, expectation_map]
+  apply tsum_congr
+  intro endpoint
+  rw [← run_posterior_payoff (auxiliary endpoint) (before endpoint) observed
+    (fun tables middle => ∑' result,
+      observedRun (auxiliary endpoint) tables (QueryCap.counted IsPrefixQuery (after endpoint middle)) middle.2 result *
+        ((EndpointPreimageDensity.preimages evaluate tables endpoint : ENNReal) * payoff (endpoint, middle, result)))]
+  simp only [expectation_scale]
+  rw [← ENNReal.tsum_mul_left]
+  apply tsum_congr
+  intro tables
+  ring
+
+theorem realCheckpointRun_density (auxiliary : State → QueryImpl auxSpec PMF)
+    (before : State → OracleComp (auxSpec + PrefixSpec n State) Checkpoint)
+    (after : State → Checkpoint × (Fin n → State → Option State) → OracleComp (auxSpec + PrefixSpec n State) Result)
+    (observed : Fin n → State → Option State)
+    (payoff : State × (Checkpoint × (Fin n → State → Option State)) × ((Result × Nat) × (Fin n → State → Option State)) → ENNReal) :
+    (∑' result, realCheckpointRun auxiliary before after observed result * payoff result) =
+    ∑' endpoint, PMF.uniformOfFintype State endpoint * ∑' middle, lazyRun (auxiliary endpoint) (before endpoint) observed middle *
+      ∑' result, lazyRun (auxiliary endpoint) (QueryCap.counted IsPrefixQuery (after endpoint middle)) middle.2 result *
+        (meanPreimages result.2 endpoint * payoff (endpoint, middle, result)) := by
+  rw [realCheckpointRun_expectation]
+  apply tsum_congr
+  intro endpoint
+  congr 1
+  apply tsum_congr
+  intro middle
+  congr 1
+  exact run_weighted_payoff (auxiliary endpoint) (QueryCap.counted IsPrefixQuery (after endpoint middle)) middle.2 endpoint
+    (fun result => payoff (endpoint, middle, result))
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCheckpointContact.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCheckpointContact.lean
new file mode 100644
index 000000000..c533f68ed
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCheckpointContact.lean
@@ -0,0 +1,90 @@
+import SphincsSecurity.Proof.Chains.AdaptiveChainCheckpoint
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+
+private theorem scaled_expectation_le {Result : Type} (law : PMF Result) (factor : ENNReal)
+    (left right : Result → ENNReal) (h : ∀ result ∈ law.support, factor * left result ≤ right result) :
+    factor * (∑' result, law result * left result) ≤ ∑' result, law result * right result := by
+  rw [← expectation_scale]
+  apply ENNReal.tsum_le_tsum
+  intro result
+  by_cases hr : result ∈ law.support
+  · exact mul_le_mul' le_rfl (h result hr)
+  · have hz : law result = 0 := not_not.mp hr
+    simp only [hz, zero_mul, le_refl]
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+  {AuxIndex : Type} {auxSpec : OracleSpec AuxIndex} {n : Nat} {Checkpoint Result : Type}
+  (auxiliary : State → QueryImpl auxSpec PMF)
+  (before : State → OracleComp (auxSpec + PrefixSpec n State) Checkpoint)
+  (after : State → Checkpoint × (Fin n → State → Option State) → OracleComp (auxSpec + PrefixSpec n State) Result)
+  (observed : Fin n → State → Option State)
+  (marked : State → Checkpoint × (Fin n → State → Option State) → Prop)
+
+theorem realCheckpointRun_mark_probability :
+    Pr[fun result => marked result.1 result.2.1 | realCheckpointRun auxiliary before after observed] =
+      Pr[fun result => marked result.1 result.2 | realRun auxiliary before observed] := by
+  have h := congrArg (fun law : PMF (State × (Checkpoint × (Fin n → State → Option State))) =>
+    Pr[fun result => marked result.1 result.2 | law]) (realCheckpointRun_before auxiliary before after observed)
+  simpa only [← PMF.monad_map_eq_map, probEvent_map, Function.comp_def] using h
+
+theorem realCheckpointRun_contact_charge (budget : Nat)
+    (hmarked : ∀ endpoint middle, marked endpoint middle → ¬Contact middle.2 endpoint)
+    (hbudget : ∀ endpoint, ∀ middle ∈ (lazyRun (auxiliary endpoint) (before endpoint) observed).support,
+      marked endpoint middle → ∀ result ∈ (lazyRun (auxiliary endpoint)
+        (QueryCap.counted IsPrefixQuery (after endpoint middle)) middle.2).support, queryCount result.2 ≤ budget) :
+    (1 - (budget : ENNReal) / Fintype.card State) * ((Fintype.card State : ENNReal) *
+      Pr[fun result => marked result.1 result.2.1 ∧ Contact result.2.2.2 result.1 |
+        realCheckpointRun auxiliary before after observed]) ≤
+      ∑' result, realCheckpointRun auxiliary before after observed result *
+        (((queryCount result.2.1.2 + 2 * result.2.2.1.2 : Nat) : ENNReal) * if marked result.1 result.2.1 then 1 else 0) := by
+  rw [show Pr[fun result => marked result.1 result.2.1 ∧ Contact result.2.2.2 result.1 |
+      realCheckpointRun auxiliary before after observed] =
+      (∑' result, realCheckpointRun auxiliary before after observed result *
+        if marked result.1 result.2.1 ∧ Contact result.2.2.2 result.1 then 1 else 0) by
+          simp only [probEvent_eq_tsum_ite, PMF.probOutput_eq_apply, mul_ite, mul_one, mul_zero]]
+  rw [realCheckpointRun_density, realCheckpointRun_expectation, ← mul_assoc]
+  apply scaled_expectation_le
+  intro endpoint _
+  apply scaled_expectation_le
+  intro middle hmiddle
+  by_cases hm : marked endpoint middle
+  · simp only [hm, true_and, if_true, mul_one]
+    simpa only [mul_assoc] using run_contact_charge_transfer (auxiliary endpoint) (after endpoint middle) middle.2 endpoint
+      (hmarked endpoint middle hm) budget (hbudget endpoint middle hmiddle hm)
+  · simp only [hm, false_and, if_false, mul_zero, tsum_zero, le_refl]
+
+theorem realCheckpointRun_contact_le_mark (budget : Nat)
+    (hmarked : ∀ endpoint middle, marked endpoint middle → ¬Contact middle.2 endpoint)
+    (hbudget : ∀ endpoint, ∀ middle ∈ (lazyRun (auxiliary endpoint) (before endpoint) observed).support,
+      marked endpoint middle → ∀ result ∈ (lazyRun (auxiliary endpoint)
+        (QueryCap.counted IsPrefixQuery (after endpoint middle)) middle.2).support, queryCount result.2 ≤ budget)
+    (hcost : ∀ result ∈ (realCheckpointRun auxiliary before after observed).support,
+      marked result.1 result.2.1 → queryCount result.2.1.2 + result.2.2.1.2 ≤ budget) :
+    (1 - (budget : ENNReal) / Fintype.card State) * ((Fintype.card State : ENNReal) *
+      Pr[fun result => marked result.1 result.2.1 ∧ Contact result.2.2.2 result.1 |
+        realCheckpointRun auxiliary before after observed]) ≤
+      (2 * budget : Nat) * Pr[fun result => marked result.1 result.2 | realRun auxiliary before observed] := by
+  apply (realCheckpointRun_contact_charge auxiliary before after observed marked budget hmarked hbudget).trans
+  calc
+    _ ≤ ∑' result, realCheckpointRun auxiliary before after observed result *
+        (((2 * budget : Nat) : ENNReal) * if marked result.1 result.2.1 then 1 else 0) := by
+      apply ENNReal.tsum_le_tsum
+      intro result
+      by_cases hr : result ∈ (realCheckpointRun auxiliary before after observed).support
+      · apply mul_le_mul' le_rfl
+        by_cases hm : marked result.1 result.2.1
+        · simp only [if_pos hm, mul_one]
+          have hc := hcost result hr hm
+          exact_mod_cast (show queryCount result.2.1.2 + 2 * result.2.2.1.2 ≤ 2 * budget by omega)
+        · simp only [if_neg hm, mul_zero, le_refl]
+      · have hz : realCheckpointRun auxiliary before after observed result = 0 := not_not.mp hr
+        simp only [hz, zero_mul, le_refl]
+    _ = _ := by
+      rw [expectation_scale, ← realCheckpointRun_mark_probability auxiliary before after observed marked]
+      simp only [probEvent_eq_tsum_ite, PMF.probOutput_eq_apply, mul_ite, mul_one, mul_zero]
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCheckpointProjection.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCheckpointProjection.lean
new file mode 100644
index 000000000..97957eae3
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCheckpointProjection.lean
@@ -0,0 +1,52 @@
+import SphincsSecurity.Proof.Chains.AdaptiveChainCheckpoint
+import SphincsSecurity.Proof.Chains.AdaptiveChainCapObservation
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+  {AuxIndex : Type} {auxSpec : OracleSpec AuxIndex} {n : Nat} {Checkpoint Result Output : Type}
+
+omit [Fintype State] [Nonempty State] in
+theorem observedRun_bind (auxiliary : QueryImpl auxSpec PMF) (tables : Fin n → State → State)
+    (before : OracleComp (auxSpec + PrefixSpec n State) Checkpoint)
+    (after : Checkpoint → OracleComp (auxSpec + PrefixSpec n State) Result) (observed : Fin n → State → Option State) :
+    observedRun auxiliary tables (before >>= after) observed =
+      (observedRun auxiliary tables before observed).bind (fun middle => observedRun auxiliary tables (after middle.1) middle.2) := by
+  simp only [observedRun, simulateQ_bind, StateT.run_bind, PMF.monad_bind_eq_bind]
+
+omit [Fintype State] [Nonempty State] in
+theorem checkpointObservedRun_project (auxiliary : QueryImpl auxSpec PMF) (tables : Fin n → State → State)
+    (before : OracleComp (auxSpec + PrefixSpec n State) Checkpoint)
+    (after : Checkpoint → OracleComp (auxSpec + PrefixSpec n State) Result)
+    (observed : Fin n → State → Option State) (project : Checkpoint → Result → Output) :
+    (checkpointObservedRun auxiliary tables before (fun middle => after middle.1) observed).map
+      (fun result => (project result.1.1 result.2.1.1, result.2.2)) =
+    observedRun auxiliary tables (do let middle ← before; let result ← after middle; pure (project middle result)) observed := by
+  simp only [checkpointObservedRun, PMF.map_bind, PMF.map_comp, Function.comp_def,
+    observedRun_bind, bind_pure_comp, observedRun_map]
+  apply congrArg (observedRun auxiliary tables before observed).bind
+  funext middle
+  rw [← observedRun_map auxiliary tables (QueryCap.counted IsPrefixQuery (after middle.1))
+    (fun result => project middle.1 result.1) middle.2]
+  rw [← Functor.map_map, QueryCap.counted_forget, observedRun_map]
+
+theorem realCheckpointRun_project (auxiliary : State → QueryImpl auxSpec PMF)
+    (before : State → OracleComp (auxSpec + PrefixSpec n State) Checkpoint)
+    (after : State → Checkpoint → OracleComp (auxSpec + PrefixSpec n State) Result)
+    (observed : Fin n → State → Option State) (project : State → Checkpoint → Result → Output) :
+    (realCheckpointRun auxiliary before (fun endpoint middle => after endpoint middle.1) observed).map
+      (fun result => (result.1, project result.1 result.2.1.1 result.2.2.1.1, result.2.2.2)) =
+    realRun auxiliary (fun endpoint => do
+      let middle ← before endpoint
+      let result ← after endpoint middle
+      pure (project endpoint middle result)) observed := by
+  simp only [realCheckpointRun, realRun, PMF.map_bind, PMF.map_comp, Function.comp_def]
+  apply congrArg (EndpointPreimageDensity.real (completeTables observed) evaluate).bind
+  funext pair
+  have h := congrArg (fun law => law.map (fun result => (pair.2, result)))
+    (checkpointObservedRun_project (auxiliary pair.2) pair.1 (before pair.2) (after pair.2) observed (project pair.2))
+  simpa only [PMF.map_comp, Function.comp_def] using h
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCompensation.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCompensation.lean
new file mode 100644
index 000000000..427a9b76e
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCompensation.lean
@@ -0,0 +1,48 @@
+import SphincsSecurity.Proof.Chains.AdaptiveChainPotential
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+private theorem compensation_compose {a b c d e f : ENNReal} (hc : c ≠ ⊤)
+    (hstep : a + d ≤ b + c) (htail : c + e ≤ d + f) : a + e ≤ b + f := by
+  apply (ENNReal.add_le_add_iff_left hc).mp
+  calc
+    c + (a + e) = a + (c + e) := by ac_rfl
+    _ ≤ a + (d + f) := _root_.add_le_add le_rfl htail
+    _ = (a + d) + f := by rw [add_assoc]
+    _ ≤ (b + c) + f := _root_.add_le_add hstep le_rfl
+    _ = c + (b + f) := by ac_rfl
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+  {AuxIndex : Type} {auxSpec : OracleSpec AuxIndex} {n : Nat} {Result : Type}
+
+theorem lazyRun_compensation (auxiliary : QueryImpl auxSpec PMF)
+    (charge weight : Nat → (Fin n → State → Option State) → ENNReal)
+    (hfinite : ∀ input observed spent,
+      (∑' output, (lazyImpl auxiliary input).run observed output *
+        charge (spent + if IsPrefixQuery input then 1 else 0) output.2) ≠ ⊤)
+    (hstep : ∀ input observed spent,
+      charge spent observed + (∑' output, (lazyImpl auxiliary input).run observed output *
+        weight (spent + if IsPrefixQuery input then 1 else 0) output.2) ≤
+      weight spent observed + ∑' output, (lazyImpl auxiliary input).run observed output *
+        charge (spent + if IsPrefixQuery input then 1 else 0) output.2)
+    (computation : OracleComp (auxSpec + PrefixSpec n State) Result)
+    (observed : Fin n → State → Option State) (spent : Nat) :
+    charge spent observed + (∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) observed result *
+      weight (spent + result.1.2) result.2) ≤
+    weight spent observed + ∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) observed result *
+      charge (spent + result.1.2) result.2 := by
+  induction computation using OracleComp.inductionOn generalizing observed spent with
+  | pure result =>
+      simp only [QueryCap.counted_pure, lazyRun_pure, expectation_pure, Nat.add_zero]
+      exact le_of_eq (add_comm _ _)
+  | query_bind input next ih =>
+      simp only [QueryCap.counted_query_bind, bind_pure_comp, lazyRun_query_bind, lazyRun_map,
+        expectation_bind, expectation_map, ← Nat.add_assoc]
+      apply compensation_compose (hfinite input observed spent) (hstep input observed spent)
+      have h := ENNReal.tsum_le_tsum fun output => mul_le_mul' (le_refl ((lazyImpl auxiliary input).run observed output))
+        (ih output.1 output.2 (spent + if IsPrefixQuery input then 1 else 0))
+      simpa only [expectation_add] using h
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainContact.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainContact.lean
new file mode 100644
index 000000000..7897d4bbc
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainContact.lean
@@ -0,0 +1,56 @@
+import SphincsSecurity.Proof.Chains.AdaptiveChainPotential
+import SphincsSecurity.Proof.Chains.PartialChainContactPotential
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+  {AuxIndex : Type} {auxSpec : OracleSpec AuxIndex} {n : Nat} {Result : Type}
+
+theorem lazyRun_counted_expectation (auxiliary : QueryImpl auxSpec PMF)
+    (computation : OracleComp (auxSpec + PrefixSpec n State) Result) (observed : Fin n → State → Option State)
+    (payoff : Result × (Fin n → State → Option State) → ENNReal) :
+    (∑' result, lazyRun auxiliary computation observed result * payoff result) =
+      ∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) observed result * payoff (result.1.1, result.2) := by
+  have h := congrArg (fun law : PMF (Result × (Fin n → State → Option State)) => ∑' result, law result * payoff result)
+    (lazyRun_map auxiliary (QueryCap.counted IsPrefixQuery computation) Prod.fst observed)
+  simpa only [QueryCap.counted_forget, expectation_map] using h
+
+theorem lazyRun_contactPotential_le (auxiliary : QueryImpl auxSpec PMF)
+    (computation : OracleComp (auxSpec + PrefixSpec n State) Result) (observed : Fin n → State → Option State) (endpoint : State) :
+    (∑' result, lazyRun auxiliary computation observed result * contactPotential result.2 endpoint) ≤
+      contactPotential observed endpoint + (2 / Fintype.card State) *
+        ∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) observed result * (result.1.2 : ENNReal) := by
+  rw [lazyRun_counted_expectation]
+  apply lazyRun_potential_le auxiliary (fun current => contactPotential current endpoint) (2 / Fintype.card State)
+  intro input current
+  cases input with
+  | inl input => simp only [lazyImpl, StateT.run_mk, expectation_map, expectation_const, IsPrefixQuery, if_false, Nat.cast_zero, mul_zero, add_zero, le_refl]
+  | inr query =>
+      simp only [lazyImpl, StateT.run_mk, expectation_map, IsPrefixQuery, if_true, Nat.cast_one, mul_one]
+      exact contactPotential_observe_le current query endpoint
+
+theorem realRun_contact_le (auxiliary : State → QueryImpl auxSpec PMF)
+    (computation : State → OracleComp (auxSpec + PrefixSpec n State) Result) :
+    Pr[fun result => Contact result.2.2 result.1 | realRun auxiliary computation (fun _ _ => none)] ≤
+      (2 / Fintype.card State) * ∑' result, idealRun auxiliary
+        (fun endpoint => QueryCap.counted IsPrefixQuery (computation endpoint)) (fun _ _ => none) result * (result.2.1.2 : ENNReal) := by
+  rw [show Pr[fun result => Contact result.2.2 result.1 | realRun auxiliary computation (fun _ _ => none)] =
+    (∑' result, realRun auxiliary computation (fun _ _ => none) result * (if Contact result.2.2 result.1 then 1 else 0)) by
+      simp only [probEvent_eq_tsum_ite, PMF.probOutput_eq_apply, mul_ite, mul_one, mul_zero]]
+  rw [realRun_expectation]
+  calc
+    _ ≤ ∑' result, idealRun auxiliary computation (fun _ _ => none) result * contactPotential result.2.2 result.1 :=
+      ENNReal.tsum_le_tsum fun result => mul_le_mul' le_rfl (contactPotential_dominates result.2.2 result.1)
+    _ ≤ _ := by
+      simp only [idealRun, expectation_bind, expectation_map]
+      rw [← expectation_scale]
+      apply ENNReal.tsum_le_tsum
+      intro endpoint
+      apply mul_le_mul' le_rfl
+      simpa only [contactPotential_empty, zero_add] using
+        lazyRun_contactPotential_le (auxiliary endpoint) (computation endpoint) (fun _ _ => none) endpoint
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainContactMoments.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainContactMoments.lean
new file mode 100644
index 000000000..e3a3e97dc
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainContactMoments.lean
@@ -0,0 +1,108 @@
+import SphincsSecurity.Proof.Chains.PartialChainContactCount
+import SphincsSecurity.Proof.Chains.AdaptiveChainBudgetPotential
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+  {AuxIndex : Type} {auxSpec : OracleSpec AuxIndex} {n : Nat} {Result : Type}
+
+noncomputable def contactMomentPotential (remaining : Nat) (observed : Fin n → State → Option State) (endpoint : State) : ENNReal :=
+  (contactFactorial (contactCount observed endpoint) : ENNReal) +
+    (2 * remaining : Nat) / (Fintype.card State : ENNReal) * (contactCount observed endpoint : ENNReal)
+
+theorem contactMomentPotential_observe_le (observed : Fin n → State → Option State) (query : Fin n × State)
+    (endpoint : State) (remaining limit : Nat) (hremaining : remaining ≤ limit) :
+    (∑' answer, rowLaw (observed query.1 query.2) answer * contactMomentPotential remaining (record observed query answer) endpoint) ≤
+      contactMomentPotential (remaining + 1) observed endpoint + (2 * limit : Nat) / (Fintype.card State : ENNReal)^2 := by
+  simp only [contactMomentPotential, expectation_add, expectation_scale]
+  calc
+    _ ≤ ((contactFactorial (contactCount observed endpoint) : ENNReal) +
+          (2 * contactCount observed endpoint : Nat) / (Fintype.card State : ENNReal)) +
+        ((2 * remaining : Nat) / (Fintype.card State : ENNReal)) *
+          ((contactCount observed endpoint : ENNReal) + 1 / Fintype.card State) :=
+      _root_.add_le_add (contactFactorial_observe_le observed query endpoint)
+        (mul_le_mul' le_rfl (contactCount_observe_le observed query endpoint))
+    _ = (contactFactorial (contactCount observed endpoint) : ENNReal) +
+          (2 * (remaining + 1) : Nat) / (Fintype.card State : ENNReal) * (contactCount observed endpoint : ENNReal) +
+          (2 * remaining : Nat) / (Fintype.card State : ENNReal)^2 := by
+      simp only [Nat.cast_add, Nat.cast_mul, Nat.cast_ofNat, Nat.cast_one, div_eq_mul_inv, ENNReal.inv_pow]
+      ring
+    _ ≤ _ := by
+      apply _root_.add_le_add le_rfl
+      have h : (2 * remaining : Nat) ≤ 2 * limit := Nat.mul_le_mul_left 2 hremaining
+      simpa only [div_eq_mul_inv] using mul_le_mul'
+        (show ((2 * remaining : Nat) : ENNReal) ≤ (2 * limit : Nat) by exact_mod_cast h)
+        (le_refl ((Fintype.card State : ENNReal)^2)⁻¹)
+
+theorem lazyRun_contactCount_le (auxiliary : QueryImpl auxSpec PMF)
+    (computation : OracleComp (auxSpec + PrefixSpec n State) Result) (observed : Fin n → State → Option State) (endpoint : State) :
+    (∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) observed result * (contactCount result.2 endpoint : ENNReal)) ≤
+      (contactCount observed endpoint : ENNReal) + (1 / Fintype.card State) *
+        ∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) observed result * (result.1.2 : ENNReal) := by
+  apply lazyRun_potential_le auxiliary (fun current => (contactCount current endpoint : ENNReal)) (1 / Fintype.card State)
+  intro input current
+  cases input with
+  | inl input => simp only [lazyImpl, StateT.run_mk, expectation_map, expectation_const, IsPrefixQuery, if_false, Nat.cast_zero, mul_zero, add_zero, le_refl]
+  | inr query =>
+      simp only [lazyImpl, StateT.run_mk, expectation_map, IsPrefixQuery, if_true, Nat.cast_one, mul_one]
+      exact contactCount_observe_le current query endpoint
+
+theorem lazyRun_contactFactorial_le (auxiliary : QueryImpl auxSpec PMF)
+    (computation : OracleComp (auxSpec + PrefixSpec n State) Result) (observed : Fin n → State → Option State)
+    (endpoint : State) (budget : Nat) (hbound : computation.IsQueryBoundP IsPrefixQuery budget) :
+    (∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) observed result *
+      (contactFactorial (contactCount result.2 endpoint) : ENNReal)) ≤
+      contactMomentPotential budget observed endpoint + ((2 * budget : Nat) / (Fintype.card State : ENNReal)^2) *
+        ∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) observed result * (result.1.2 : ENNReal) := by
+  apply lazyRun_budget_potential_le auxiliary (fun remaining current => contactMomentPotential remaining current endpoint)
+    (fun current => (contactFactorial (contactCount current endpoint) : ENNReal))
+    ((2 * budget : Nat) / (Fintype.card State : ENNReal)^2) budget
+    (fun _ _ => _root_.le_add_of_nonneg_right bot_le) ?_ computation observed budget le_rfl hbound
+  intro input current remaining hremaining hpositive
+  cases input with
+  | inl input => simp only [lazyImpl, StateT.run_mk, expectation_map, expectation_const, IsPrefixQuery, if_false, Nat.cast_zero, mul_zero, add_zero, le_refl]
+  | inr query =>
+      have hpos : 0 < remaining := by simpa only [IsPrefixQuery, not_true_eq_false, false_or] using hpositive
+      cases remaining with
+      | zero => omega
+      | succ remaining =>
+          simp only [lazyImpl, StateT.run_mk, expectation_map, IsPrefixQuery, if_true, Nat.cast_one, mul_one, Nat.add_sub_cancel]
+          exact contactMomentPotential_observe_le current query endpoint remaining budget (by omega)
+
+theorem lazyRun_empty_contactCount_le (auxiliary : QueryImpl auxSpec PMF)
+    (computation : OracleComp (auxSpec + PrefixSpec n State) Result) (endpoint : State) :
+    (∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) (fun _ _ => none) result *
+      (contactCount result.2 endpoint : ENNReal)) ≤
+      (1 / Fintype.card State) * ∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) (fun _ _ => none) result *
+        (result.1.2 : ENNReal) := by
+  simpa only [contactCount_empty, Nat.cast_zero, zero_add] using lazyRun_contactCount_le auxiliary computation (fun _ _ => none) endpoint
+
+theorem lazyRun_empty_contactFactorial_le (auxiliary : QueryImpl auxSpec PMF)
+    (computation : OracleComp (auxSpec + PrefixSpec n State) Result) (endpoint : State)
+    (budget : Nat) (hbound : computation.IsQueryBoundP IsPrefixQuery budget) :
+    (∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) (fun _ _ => none) result *
+      (contactFactorial (contactCount result.2 endpoint) : ENNReal)) ≤
+      ((2 * budget : Nat) / (Fintype.card State : ENNReal)^2) *
+        ∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) (fun _ _ => none) result * (result.1.2 : ENNReal) := by
+  simpa only [contactMomentPotential, contactCount_empty, contactFactorial, Nat.zero_mul, Nat.cast_zero, mul_zero, zero_add] using
+    lazyRun_contactFactorial_le auxiliary computation (fun _ _ => none) endpoint budget hbound
+
+theorem lazyRun_empty_contact_correction (auxiliary : QueryImpl auxSpec PMF)
+    (computation : OracleComp (auxSpec + PrefixSpec n State) Result) (endpoint : State)
+    (budget : Nat) (hbound : computation.IsQueryBoundP IsPrefixQuery budget) :
+    ((budget : ENNReal) / Fintype.card State) *
+      (∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) (fun _ _ => none) result *
+        ((contactFactorial (contactCount result.2 endpoint) + 4 * contactCount result.2 endpoint : Nat) : ENNReal)) ≤
+      ((4 * ((budget : ENNReal) / Fintype.card State) + 2 * ((budget : ENNReal) / Fintype.card State)^2) / Fintype.card State) *
+        ∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) (fun _ _ => none) result * (result.1.2 : ENNReal) := by
+  simp only [Nat.cast_add, Nat.cast_mul, Nat.cast_ofNat, expectation_add, expectation_scale]
+  have h := mul_le_mul' (le_refl ((budget : ENNReal) / Fintype.card State))
+    (_root_.add_le_add (lazyRun_empty_contactFactorial_le auxiliary computation endpoint budget hbound)
+      (mul_le_mul' (le_refl (4 : ENNReal)) (lazyRun_empty_contactCount_le auxiliary computation endpoint)))
+  apply h.trans_eq
+  simp only [Nat.cast_mul, Nat.cast_ofNat, div_eq_mul_inv, ENNReal.inv_pow]
+  ring
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCountedRows.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCountedRows.lean
new file mode 100644
index 000000000..cd0097a99
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainCountedRows.lean
@@ -0,0 +1,45 @@
+import SphincsSecurity.Proof.Chains.AdaptiveChainCapContact
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+  {AuxIndex : Type} {auxSpec : OracleSpec AuxIndex} {n : Nat} {Result : Type}
+
+theorem lazyRun_counted_queryCount_le (auxiliary : QueryImpl auxSpec PMF)
+    (computation : OracleComp (auxSpec + PrefixSpec n State) Result) (observed : Fin n → State → Option State)
+    (result : (Result × Nat) × (Fin n → State → Option State))
+    (hresult : result ∈ (lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) observed).support) :
+    queryCount result.2 ≤ queryCount observed + result.1.2 := by
+  induction computation using OracleComp.inductionOn generalizing observed result with
+  | pure value =>
+      rw [QueryCap.counted_pure, lazyRun_pure, PMF.mem_support_pure_iff] at hresult
+      subst result
+      exact le_rfl
+  | query_bind input next ih =>
+      cases input with
+      | inl input =>
+          simp only [QueryCap.counted_query_bind, bind_pure_comp, lazyRun_query_bind, lazyRun_map,
+            lazyImpl, StateT.run_mk, PMF.bind_map, Function.comp_def, PMF.mem_support_bind_iff, PMF.mem_support_map_iff] at hresult
+          obtain ⟨answer, _, tail, htail, rfl⟩ := hresult
+          simpa only [IsPrefixQuery, if_false, Nat.zero_add] using ih answer observed tail htail
+      | inr query =>
+          simp only [QueryCap.counted_query_bind, bind_pure_comp, lazyRun_query_bind, lazyRun_map,
+            lazyImpl, StateT.run_mk, PMF.bind_map, Function.comp_def, PMF.mem_support_bind_iff, PMF.mem_support_map_iff] at hresult
+          obtain ⟨answer, _, tail, htail, rfl⟩ := hresult
+          have ht := ih answer (record observed query answer) tail htail
+          have hr := queryCount_record_le observed query answer
+          simp only [IsPrefixQuery, if_true]
+          omega
+
+theorem lazyRun_counted_budget_le (auxiliary : QueryImpl auxSpec PMF)
+    (computation : OracleComp (auxSpec + PrefixSpec n State) Result) (observed : Fin n → State → Option State)
+    (budget : Nat) (hbound : computation.IsQueryBoundP IsPrefixQuery budget)
+    (result : (Result × Nat) × (Fin n → State → Option State))
+    (hresult : result ∈ (lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) observed).support) :
+    result.1.2 ≤ budget :=
+  QueryCap.counted_le_of_queryBound IsPrefixQuery computation budget hbound result.1
+    (lazyRun_result_mem auxiliary (QueryCap.counted IsPrefixQuery computation) observed result hresult)
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainEndpoint.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainEndpoint.lean
new file mode 100644
index 000000000..bdb245481
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainEndpoint.lean
@@ -0,0 +1,98 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Chains.AdaptiveChainLikelihood
+import SphincsSecurity.Proof.Chains.AdaptiveChainQueryBound
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec ENNReal
+set_option backward.isDefEq.respectTransparency false
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+  {AuxIndex : Type} {auxSpec : OracleSpec AuxIndex} {n : Nat} {Result : Type}
+
+noncomputable def realRun (auxiliary : State → QueryImpl auxSpec PMF)
+    (computation : State → OracleComp (auxSpec + PrefixSpec n State) Result)
+    (observed : Fin n → State → Option State) : PMF (State × (Result × (Fin n → State → Option State))) :=
+  (EndpointPreimageDensity.real (completeTables observed) evaluate).bind (fun pair =>
+    (observedRun (auxiliary pair.2) pair.1 (computation pair.2) observed).map (fun result => (pair.2, result)))
+
+noncomputable def idealRun (auxiliary : State → QueryImpl auxSpec PMF)
+    (computation : State → OracleComp (auxSpec + PrefixSpec n State) Result)
+    (observed : Fin n → State → Option State) : PMF (State × (Result × (Fin n → State → Option State))) :=
+  (PMF.uniformOfFintype State).bind (fun endpoint =>
+    (lazyRun (auxiliary endpoint) (computation endpoint) observed).map (fun result => (endpoint, result)))
+
+theorem realRun_expectation (auxiliary : State → QueryImpl auxSpec PMF)
+    (computation : State → OracleComp (auxSpec + PrefixSpec n State) Result)
+    (observed : Fin n → State → Option State)
+    (payoff : State × (Result × (Fin n → State → Option State)) → ENNReal) :
+    (∑' result, realRun auxiliary computation observed result * payoff result) =
+      ∑' result, idealRun auxiliary computation observed result *
+        (meanPreimages result.2.2 result.1 * payoff result) := by
+  classical
+  letI : DecidableEq (Fin n → State → State) := Classical.decEq _
+  simp only [realRun, expectation_bind, expectation_map]
+  rw [EndpointPreimageDensity.real_payoff, ENNReal.tsum_prod', ENNReal.tsum_comm]
+  simp only [EndpointPreimageDensity.ideal_apply, div_eq_mul_inv]
+  simp only [idealRun, expectation_bind, expectation_map, PMF.uniformOfFintype_apply]
+  apply tsum_congr
+  intro endpoint
+  rw [← run_weighted_payoff (auxiliary endpoint) (computation endpoint) observed endpoint
+    (fun result => payoff (endpoint, result)), ← ENNReal.tsum_mul_left]
+  apply tsum_congr
+  intro tables
+  have hfactor :
+      (∑' result, observedRun (auxiliary endpoint) tables (computation endpoint) observed result *
+        ((EndpointPreimageDensity.preimages evaluate tables endpoint : ENNReal) * payoff (endpoint, result))) =
+      (EndpointPreimageDensity.preimages evaluate tables endpoint : ENNReal) *
+        ∑' result, observedRun (auxiliary endpoint) tables (computation endpoint) observed result * payoff (endpoint, result) := by
+    rw [← ENNReal.tsum_mul_left]
+    apply tsum_congr
+    intro result
+    ring
+  rw [hfactor]
+  ring
+
+theorem idealRun_queryCount_le (auxiliary : State → QueryImpl auxSpec PMF)
+    (computation : State → OracleComp (auxSpec + PrefixSpec n State) Result)
+    (observed : Fin n → State → Option State) (budget : Nat)
+    (hbound : ∀ endpoint, (computation endpoint).IsQueryBoundP IsPrefixQuery budget)
+    (result : State × (Result × (Fin n → State → Option State)))
+    (hresult : result ∈ (idealRun auxiliary computation observed).support) :
+    queryCount result.2.2 ≤ queryCount observed + budget := by
+  rw [idealRun, PMF.mem_support_bind_iff] at hresult
+  obtain ⟨endpoint, _, hresult⟩ := hresult
+  rw [PMF.mem_support_map_iff] at hresult
+  obtain ⟨output, houtput, rfl⟩ := hresult
+  exact lazyRun_queryCount_le (auxiliary endpoint) (computation endpoint) observed budget (hbound endpoint) output houtput
+
+theorem realRun_cost_lower (auxiliary : State → QueryImpl auxSpec PMF)
+    (computation : State → OracleComp (auxSpec + PrefixSpec n State) Result)
+    (observed : Fin n → State → Option State) (budget : Nat)
+    (hbound : ∀ endpoint, (computation endpoint).IsQueryBoundP IsPrefixQuery budget)
+    (payoff : State × (Result × (Fin n → State → Option State)) → ENNReal) :
+    (1 - ((queryCount observed + budget : Nat) : ENNReal) / Fintype.card State) *
+        (∑' result, idealRun auxiliary computation observed result * payoff result) ≤
+      ∑' result, realRun auxiliary computation observed result * payoff result := by
+  rw [realRun_expectation, ← ENNReal.tsum_mul_left]
+  apply ENNReal.tsum_le_tsum
+  intro result
+  by_cases hzero : idealRun auxiliary computation observed result = 0
+  · simp only [hzero, zero_mul, mul_zero, le_refl]
+  · have hlower := meanPreimages_ge_budget result.2.2 result.1 (queryCount observed + budget)
+      (idealRun_queryCount_le auxiliary computation observed budget hbound result hzero)
+    calc
+      _ = idealRun auxiliary computation observed result *
+          ((1 - ((queryCount observed + budget : Nat) : ENNReal) / Fintype.card State) * payoff result) := by ring
+      _ ≤ _ := mul_le_mul_right (mul_le_mul_left hlower (payoff result)) _
+
+theorem realRun_empty_cost_lower (auxiliary : State → QueryImpl auxSpec PMF)
+    (computation : State → OracleComp (auxSpec + PrefixSpec n State) Result) (budget : Nat)
+    (hbound : ∀ endpoint, (computation endpoint).IsQueryBoundP IsPrefixQuery budget)
+    (payoff : State × (Result × (Fin n → State → Option State)) → ENNReal) :
+    (1 - (budget : ENNReal) / Fintype.card State) *
+        (∑' result, idealRun auxiliary computation (fun _ _ => none) result * payoff result) ≤
+      ∑' result, realRun auxiliary computation (fun _ _ => none) result * payoff result := by
+  simpa only [queryCount_empty, zero_add] using
+    realRun_cost_lower auxiliary computation (fun _ _ => none) budget hbound payoff
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainErasure.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainErasure.lean
new file mode 100644
index 000000000..8e06acaf4
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainErasure.lean
@@ -0,0 +1,52 @@
+import SphincsSecurity.Proof.Chains.AdaptiveChainEndpoint
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+  {AuxIndex : Type} {auxSpec : OracleSpec AuxIndex} {n : Nat}
+
+noncomputable def fixedImpl (auxiliary : QueryImpl auxSpec PMF) (tables : Fin n → State → State) :
+    QueryImpl (auxSpec + PrefixSpec n State) PMF :=
+  auxiliary + (fun (query : Fin n × State) => PMF.pure (tables query.1 query.2) : QueryImpl (PrefixSpec n State) PMF)
+
+omit [Fintype State] [Nonempty State] in
+theorem observedRun_forget {Result : Type} (auxiliary : QueryImpl auxSpec PMF) (tables : Fin n → State → State)
+    (computation : OracleComp (auxSpec + PrefixSpec n State) Result) (observed : Fin n → State → Option State) :
+    (observedRun auxiliary tables computation observed).map Prod.fst = simulateQ (fixedImpl auxiliary tables) computation := by
+  induction computation using OracleComp.inductionOn generalizing observed with
+  | pure result =>
+      simp only [observedRun_pure, ← PMF.monad_map_eq_map, ← PMF.monad_pure_eq_pure, map_pure, simulateQ_pure]
+  | query_bind input next ih =>
+      rw [observedRun_query_bind, PMF.map_bind, simulateQ_bind, simulateQ_spec_query]
+      cases input with
+      | inl input =>
+          simp only [observedImpl, StateT.run_mk, PMF.bind_map, PMF.monad_bind_eq_bind, fixedImpl, QueryImpl.add_apply_inl]
+          exact congrArg (auxiliary input).bind (funext fun answer => ih answer observed)
+      | inr query =>
+          simp only [observedImpl, StateT.run_mk, PMF.pure_bind, fixedImpl, QueryImpl.add_apply_inr,
+            PMF.monad_bind_eq_bind, PMF.pure_bind]
+          exact ih (tables query.1 query.2) (record observed query (tables query.1 query.2))
+
+theorem realRun_empty_forget {Result : Type} (auxiliary : State → QueryImpl auxSpec PMF)
+    (computation : State → OracleComp (auxSpec + PrefixSpec n State) Result) :
+    (realRun auxiliary computation (fun _ _ => none)).map (fun result => result.2.1) =
+      (PMF.uniformOfFintype (Fin n → State → State)).bind (fun tables =>
+        (PMF.uniformOfFintype State).bind (fun secret =>
+          simulateQ (fixedImpl (auxiliary (evaluate tables secret)) tables) (computation (evaluate tables secret)))) := by
+  simp only [realRun, completeTables_empty, EndpointPreimageDensity.real, PMF.map_bind, PMF.bind_bind, PMF.bind_map,
+    PMF.map_comp, Function.comp_def, observedRun_forget]
+
+theorem realRun_empty_result_mem {Result : Type} (auxiliary : State → QueryImpl auxSpec PMF)
+    (computation : State → OracleComp (auxSpec + PrefixSpec n State) Result)
+    (tables : Fin n → State → State) (secret : State) (result : Result)
+    (hresult : result ∈ (simulateQ (fixedImpl (auxiliary (evaluate tables secret)) tables)
+      (computation (evaluate tables secret))).support) :
+    result ∈ ((realRun auxiliary computation (fun _ _ => none)).map (fun result => result.2.1)).support := by
+  rw [realRun_empty_forget, PMF.mem_support_bind_iff]
+  refine ⟨tables, PMF.mem_support_uniformOfFintype tables, ?_⟩
+  rw [PMF.mem_support_bind_iff]
+  exact ⟨secret, PMF.mem_support_uniformOfFintype secret, hresult⟩
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainLikelihood.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainLikelihood.lean
new file mode 100644
index 000000000..9cfae8590
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainLikelihood.lean
@@ -0,0 +1,61 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Chains.AdaptiveChainObservation
+import SphincsSecurity.Proof.Chains.PartialChainLikelihoodLower
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec ENNReal
+set_option backward.isDefEq.respectTransparency false
+
+theorem expectation_bind {First Second : Type} (prior : PMF First) (next : First → PMF Second)
+    (payoff : Second → ENNReal) :
+    (∑' result, prior.bind next result * payoff result) =
+      ∑' first, prior first * ∑' result, next first result * payoff result := by
+  simpa only [PMF.probOutput_eq_apply, PMF.monad_bind_eq_bind] using
+    tsum_probOutput_bind_mul prior next payoff
+
+theorem expectation_map {First Second : Type} (prior : PMF First) (next : First → Second)
+    (payoff : Second → ENNReal) :
+    (∑' result, prior.map next result * payoff result) = ∑' first, prior first * payoff (next first) := by
+  simpa only [PMF.probOutput_eq_apply, PMF.monad_map_eq_map] using
+    tsum_probOutput_map_mul prior next payoff
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+  {AuxIndex : Type} {auxSpec : OracleSpec AuxIndex} {n : Nat}
+
+theorem run_weighted_payoff {Result : Type} (auxiliary : QueryImpl auxSpec PMF)
+    (computation : OracleComp (auxSpec + PrefixSpec n State) Result) (observed : Fin n → State → Option State)
+    (endpoint : State) (payoff : Result × (Fin n → State → Option State) → ENNReal) :
+    (∑' tables, completeTables observed tables * ∑' result, observedRun auxiliary tables computation observed result *
+      ((EndpointPreimageDensity.preimages evaluate tables endpoint : ENNReal) * payoff result)) =
+        ∑' result, lazyRun auxiliary computation observed result * (meanPreimages result.2 endpoint * payoff result) := by
+  have h := congrArg (fun law : PMF ((Fin n → State → State) × (Result × (Fin n → State → Option State))) =>
+    ∑' result, law result * ((EndpointPreimageDensity.preimages evaluate result.1 endpoint : ENNReal) * payoff result.2))
+    (run_posterior auxiliary computation observed)
+  simp only [expectation_bind, expectation_map] at h
+  rw [h]
+  apply tsum_congr
+  intro result
+  congr 1
+  simp only [meanPreimages, ← mul_assoc, ENNReal.tsum_mul_right]
+
+theorem run_allocated_cost_lower {Result : Type} (auxiliary : QueryImpl auxSpec PMF)
+    (computation : OracleComp (auxSpec + PrefixSpec n State) Result) (observed : Fin n → State → Option State)
+    (endpoint : State) (payoff : Result × (Fin n → State → Option State) → ENNReal) (budget : Nat)
+    (hbudget : ∀ result ∈ (lazyRun auxiliary computation observed).support, queryCount result.2 ≤ budget) :
+    (1 - (budget : ENNReal) / Fintype.card State) *
+        (∑' result, lazyRun auxiliary computation observed result * payoff result) ≤
+      ∑' tables, completeTables observed tables * ∑' result, observedRun auxiliary tables computation observed result *
+        ((EndpointPreimageDensity.preimages evaluate tables endpoint : ENNReal) * payoff result) := by
+  rw [run_weighted_payoff, ← ENNReal.tsum_mul_left]
+  apply ENNReal.tsum_le_tsum
+  intro result
+  by_cases hzero : lazyRun auxiliary computation observed result = 0
+  · simp only [hzero, zero_mul, mul_zero, le_refl]
+  · have hlower := meanPreimages_ge_budget result.2 endpoint budget
+      (hbudget result hzero)
+    calc
+      _ = lazyRun auxiliary computation observed result *
+          ((1 - (budget : ENNReal) / Fintype.card State) * payoff result) := by ring
+      _ ≤ _ := mul_le_mul_right (mul_le_mul_left hlower (payoff result)) _
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainObservation.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainObservation.lean
new file mode 100644
index 000000000..0685e2f5d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainObservation.lean
@@ -0,0 +1,91 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Chains.PartialChainObservation
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec ENNReal
+set_option backward.isDefEq.respectTransparency false
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+  {AuxIndex : Type} {auxSpec : OracleSpec AuxIndex} {n : Nat}
+
+abbrev PrefixSpec (n : Nat) (State : Type) := (Fin n × State) →ₒ State
+
+noncomputable def observedImpl (auxiliary : QueryImpl auxSpec PMF) (tables : Fin n → State → State) :
+    QueryImpl (auxSpec + PrefixSpec n State) (StateT (Fin n → State → Option State) PMF)
+  | .inl input => StateT.mk fun observed => (auxiliary input).map (fun answer => (answer, observed))
+  | .inr query => StateT.mk fun observed =>
+      PMF.pure (tables query.1 query.2, record observed query (tables query.1 query.2))
+
+noncomputable def lazyImpl (auxiliary : QueryImpl auxSpec PMF) :
+    QueryImpl (auxSpec + PrefixSpec n State) (StateT (Fin n → State → Option State) PMF)
+  | .inl input => StateT.mk fun observed => (auxiliary input).map (fun answer => (answer, observed))
+  | .inr query => StateT.mk fun observed =>
+      (rowLaw (observed query.1 query.2)).map (fun answer => (answer, record observed query answer))
+
+noncomputable def observedRun {Result : Type} (auxiliary : QueryImpl auxSpec PMF) (tables : Fin n → State → State)
+    (computation : OracleComp (auxSpec + PrefixSpec n State) Result) (observed : Fin n → State → Option State) :
+    PMF (Result × (Fin n → State → Option State)) :=
+  (simulateQ (observedImpl auxiliary tables) computation).run observed
+
+noncomputable def lazyRun {Result : Type} (auxiliary : QueryImpl auxSpec PMF)
+    (computation : OracleComp (auxSpec + PrefixSpec n State) Result) (observed : Fin n → State → Option State) :
+    PMF (Result × (Fin n → State → Option State)) :=
+  (simulateQ (lazyImpl auxiliary) computation).run observed
+
+omit [Fintype State] [Nonempty State] in
+theorem observedRun_pure {Result : Type} (auxiliary : QueryImpl auxSpec PMF) (tables : Fin n → State → State)
+    (result : Result) (observed : Fin n → State → Option State) :
+    observedRun auxiliary tables (pure result) observed = PMF.pure (result, observed) := by
+  simp only [observedRun, simulateQ_pure, StateT.run_pure, PMF.monad_pure_eq_pure]
+
+theorem lazyRun_pure {Result : Type} (auxiliary : QueryImpl auxSpec PMF)
+    (result : Result) (observed : Fin n → State → Option State) :
+    lazyRun auxiliary (pure result) observed = PMF.pure (result, observed) := by
+  simp only [lazyRun, simulateQ_pure, StateT.run_pure, PMF.monad_pure_eq_pure]
+
+omit [Fintype State] [Nonempty State] in
+theorem observedRun_query_bind {Result : Type} (auxiliary : QueryImpl auxSpec PMF) (tables : Fin n → State → State)
+    (input : (auxSpec + PrefixSpec n State).Domain)
+    (next : (auxSpec + PrefixSpec n State).Range input → OracleComp (auxSpec + PrefixSpec n State) Result)
+    (observed : Fin n → State → Option State) :
+    observedRun auxiliary tables (liftM ((auxSpec + PrefixSpec n State).query input) >>= next) observed =
+      ((observedImpl auxiliary tables input).run observed).bind
+        (fun result => observedRun auxiliary tables (next result.1) result.2) := by
+  simp only [observedRun, simulateQ_bind, simulateQ_spec_query, StateT.run_bind, PMF.monad_bind_eq_bind]
+
+theorem lazyRun_query_bind {Result : Type} (auxiliary : QueryImpl auxSpec PMF)
+    (input : (auxSpec + PrefixSpec n State).Domain)
+    (next : (auxSpec + PrefixSpec n State).Range input → OracleComp (auxSpec + PrefixSpec n State) Result)
+    (observed : Fin n → State → Option State) :
+    lazyRun auxiliary (liftM ((auxSpec + PrefixSpec n State).query input) >>= next) observed =
+      ((lazyImpl auxiliary input).run observed).bind (fun result => lazyRun auxiliary (next result.1) result.2) := by
+  simp only [lazyRun, simulateQ_bind, simulateQ_spec_query, StateT.run_bind, PMF.monad_bind_eq_bind]
+
+theorem run_posterior {Result : Type} (auxiliary : QueryImpl auxSpec PMF)
+    (computation : OracleComp (auxSpec + PrefixSpec n State) Result) (observed : Fin n → State → Option State) :
+    (completeTables observed).bind (fun tables =>
+      (observedRun auxiliary tables computation observed).map (fun result => (tables, result))) =
+        (lazyRun auxiliary computation observed).bind (fun result =>
+          (completeTables result.2).map (fun tables => (tables, result))) := by
+  induction computation using OracleComp.inductionOn generalizing observed with
+  | pure result =>
+      simp only [observedRun_pure, lazyRun_pure, PMF.pure_bind, PMF.map, PMF.pure_bind]
+      rfl
+  | query_bind input next ih =>
+      cases input with
+      | inl input =>
+          simp only [observedRun_query_bind, lazyRun_query_bind, observedImpl, lazyImpl,
+            StateT.run_mk, PMF.bind_map, PMF.map_bind, PMF.bind_bind]
+          rw [PMF.bind_comm]
+          exact congrArg (fun continuation => (auxiliary input).bind continuation)
+            (funext fun answer => ih answer observed)
+      | inr query =>
+          simp only [observedRun_query_bind, lazyRun_query_bind, observedImpl, lazyImpl,
+            StateT.run_mk, PMF.pure_bind, PMF.bind_map, PMF.bind_bind]
+          rw [completeTables_bind_observe observed query (fun answer tables =>
+            (observedRun auxiliary tables (next answer) (record observed query answer)).map
+              (fun result => (tables, result)))]
+          exact congrArg (fun continuation => (rowLaw (observed query.1 query.2)).bind continuation)
+            (funext fun answer => ih answer (record observed query answer))
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainPotential.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainPotential.lean
new file mode 100644
index 000000000..95a4b22fd
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainPotential.lean
@@ -0,0 +1,60 @@
+import SphincsSecurity.Proof.Chains.AdaptiveChainEndpoint
+import SphincsSecurity.Proof.Base.QueryCap
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+theorem expectation_pure {Result : Type} (result : Result) (payoff : Result → ENNReal) :
+    (∑' output, PMF.pure result output * payoff output) = payoff result := by
+  simpa only [PMF.probOutput_eq_apply, PMF.monad_pure_eq_pure] using
+    tsum_probOutput_pure_mul (m := PMF) result payoff
+
+theorem expectation_add {Result : Type} (law : PMF Result) (first second : Result → ENNReal) :
+    (∑' result, law result * (first result + second result)) =
+      (∑' result, law result * first result) + ∑' result, law result * second result := by
+  simp only [mul_add, ENNReal.tsum_add]
+
+theorem expectation_scale {Result : Type} (law : PMF Result) (factor : ENNReal) (payoff : Result → ENNReal) :
+    (∑' result, law result * (factor * payoff result)) = factor * ∑' result, law result * payoff result := by
+  simp only [mul_left_comm _ factor, ENNReal.tsum_mul_left]
+
+theorem expectation_const {Result : Type} (law : PMF Result) (value : ENNReal) :
+    (∑' result, law result * value) = value := by
+  rw [ENNReal.tsum_mul_right, PMF.tsum_coe, one_mul]
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+  {AuxIndex : Type} {auxSpec : OracleSpec AuxIndex} {n : Nat} {Result Next : Type}
+
+theorem lazyRun_map (auxiliary : QueryImpl auxSpec PMF) (computation : OracleComp (auxSpec + PrefixSpec n State) Result)
+    (f : Result → Next) (observed : Fin n → State → Option State) :
+    lazyRun auxiliary (f <$> computation) observed = (lazyRun auxiliary computation observed).map (fun result => (f result.1, result.2)) := by
+  simp only [lazyRun, simulateQ_map, StateT.run_map, PMF.monad_map_eq_map]
+
+theorem lazyRun_potential_le (auxiliary : QueryImpl auxSpec PMF)
+    (potential : (Fin n → State → Option State) → ENNReal) (rate : ENNReal)
+    (hstep : ∀ input observed,
+      (∑' result, (lazyImpl auxiliary input).run observed result * potential result.2) ≤
+        potential observed + rate * ((if IsPrefixQuery input then 1 else 0 : Nat) : ENNReal))
+    (computation : OracleComp (auxSpec + PrefixSpec n State) Result) (observed : Fin n → State → Option State) :
+    (∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) observed result * potential result.2) ≤
+      potential observed + rate *
+        ∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) observed result * (result.1.2 : ENNReal) := by
+  induction computation using OracleComp.inductionOn generalizing observed with
+  | pure result => simp only [QueryCap.counted_pure, lazyRun_pure, expectation_pure, Nat.cast_zero, mul_zero, add_zero, le_refl]
+  | query_bind input next ih =>
+      simp only [QueryCap.counted_query_bind, bind_pure_comp, lazyRun_query_bind, lazyRun_map,
+        expectation_bind, expectation_map, Nat.cast_add, expectation_add, expectation_const]
+      calc
+        _ ≤ ∑' output, (lazyImpl auxiliary input).run observed output *
+            (potential output.2 + rate * ∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery (next output.1)) output.2 result *
+              (result.1.2 : ENNReal)) := ENNReal.tsum_le_tsum fun output => mul_le_mul' le_rfl (ih output.1 output.2)
+        _ = (∑' output, (lazyImpl auxiliary input).run observed output * potential output.2) +
+            rate * ∑' output, (lazyImpl auxiliary input).run observed output *
+              ∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery (next output.1)) output.2 result * (result.1.2 : ENNReal) := by
+          rw [expectation_add, expectation_scale]
+        _ ≤ _ := by
+          rw [mul_add, ← add_assoc]
+          exact _root_.add_le_add (hstep input observed) le_rfl
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainQueryBound.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainQueryBound.lean
new file mode 100644
index 000000000..27c0ef59c
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainQueryBound.lean
@@ -0,0 +1,75 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Chains.AdaptiveChainObservation
+import SphincsSecurity.Proof.Chains.PartialChainLikelihoodLower
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec ENNReal
+set_option backward.isDefEq.respectTransparency false
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+  {AuxIndex : Type} {auxSpec : OracleSpec AuxIndex} {n : Nat}
+
+omit [Nonempty State] in
+theorem unqueried_update_some (observed : State → Option State) (input answer : State) :
+    unqueried (Function.update observed input (some answer)) = (unqueried observed).erase input := by
+  ext row
+  by_cases hrow : row = input <;> simp [unqueried, Function.update_apply, hrow]
+
+omit [Nonempty State] in
+theorem queriedCount_update_le (observed : State → Option State) (input answer : State) :
+    queriedCount (Function.update observed input (some answer)) ≤ queriedCount observed + 1 := by
+  rw [queriedCount, unqueried_update_some, queriedCount]
+  have h := Finset.pred_card_le_card_erase (s := unqueried observed) (a := input)
+  omega
+
+omit [Nonempty State] in
+theorem queryCount_record_le (observed : Fin n → State → Option State) (query : Fin n × State) (answer : State) :
+    queryCount (record observed query answer) ≤ queryCount observed + 1 := by
+  have hfun : (fun step => queriedCount (record observed query answer step)) =
+      Function.update (fun step => queriedCount (observed step)) query.1
+        (queriedCount (Function.update (observed query.1) query.2 (some answer))) := by
+    funext step
+    by_cases hstep : step = query.1 <;> simp only [record, Function.update_apply, hstep, if_true, if_false]
+  rw [queryCount, hfun, Finset.sum_update_of_mem (Finset.mem_univ query.1), Finset.sdiff_singleton_eq_erase,
+    queryCount, ← Finset.add_sum_erase Finset.univ (fun step => queriedCount (observed step)) (Finset.mem_univ query.1)]
+  have h := queriedCount_update_le (observed query.1) query.2 answer
+  omega
+
+omit [DecidableEq State] [Nonempty State] in
+theorem queryCount_empty : queryCount (fun (_ : Fin n) (_ : State) => none) = 0 := by
+  simp [queryCount, queriedCount, unqueried]
+
+def IsPrefixQuery : AuxIndex ⊕ (Fin n × State) → Prop
+  | .inl _ => False
+  | .inr _ => True
+
+instance instDecidableIsPrefixQuery (input : AuxIndex ⊕ (Fin n × State)) : Decidable (IsPrefixQuery input) := by
+  cases input <;> unfold IsPrefixQuery <;> infer_instance
+
+theorem lazyRun_queryCount_le {Result : Type} (auxiliary : QueryImpl auxSpec PMF)
+    (computation : OracleComp (auxSpec + PrefixSpec n State) Result) (observed : Fin n → State → Option State)
+    (budget : Nat) (hbound : computation.IsQueryBoundP IsPrefixQuery budget)
+    (result : Result × (Fin n → State → Option State)) (hresult : result ∈ (lazyRun auxiliary computation observed).support) :
+    queryCount result.2 ≤ queryCount observed + budget := by
+  induction computation using OracleComp.inductionOn generalizing observed budget result with
+  | pure value =>
+      rw [lazyRun_pure, PMF.mem_support_pure_iff] at hresult
+      subst result
+      exact Nat.le_add_right _ _
+  | query_bind input next ih =>
+      rw [isQueryBoundP_query_bind_iff] at hbound
+      rw [lazyRun_query_bind] at hresult
+      cases input with
+      | inl input =>
+          simp only [lazyImpl, StateT.run_mk, PMF.bind_map, PMF.mem_support_bind_iff] at hresult
+          obtain ⟨answer, _, hresult⟩ := hresult
+          exact ih answer observed budget (hbound.2 answer) result hresult
+      | inr query =>
+          simp only [lazyImpl, StateT.run_mk, PMF.bind_map, PMF.mem_support_bind_iff] at hresult
+          obtain ⟨answer, _, hresult⟩ := hresult
+          have hpos : 0 < budget := by simpa only [IsPrefixQuery, not_true_eq_false, false_or] using hbound.1
+          have hnext := ih answer (record observed query answer) (budget - 1) (hbound.2 answer) result hresult
+          have hrecord := queryCount_record_le observed query answer
+          omega
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainRestart.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainRestart.lean
new file mode 100644
index 000000000..8bdf6dacd
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainRestart.lean
@@ -0,0 +1,56 @@
+import SphincsSecurity.Proof.Chains.AdaptiveChainContact
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+  {AuxIndex : Type} {auxSpec : OracleSpec AuxIndex} {n : Nat} {Result : Type}
+
+theorem lazyRun_contact_charge (auxiliary : QueryImpl auxSpec PMF)
+    (computation : OracleComp (auxSpec + PrefixSpec n State) Result) (observed : Fin n → State → Option State)
+    (endpoint : State) (hc : ¬Contact observed endpoint) :
+    (∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) observed result *
+      (meanPreimages result.2 endpoint * (if Contact result.2 endpoint then 1 else 0))) ≤
+      (∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) observed result *
+        ((queryCount observed + 2 * result.1.2 : Nat) : ENNReal)) / Fintype.card State := by
+  have h := lazyRun_contactPotential_le auxiliary computation observed endpoint
+  rw [lazyRun_counted_expectation] at h
+  have hinit : contactPotential observed endpoint ≤ (queryCount observed : ENNReal) / Fintype.card State := by
+    rw [contactPotential, if_neg hc]
+    have hp : pendingCount observed ≤ queryCount observed := Nat.sub_le _ _
+    simpa only [div_eq_mul_inv] using mul_le_mul' (show (pendingCount observed : ENNReal) ≤ queryCount observed by exact_mod_cast hp)
+      (le_refl (Fintype.card State : ENNReal)⁻¹)
+  calc
+    _ ≤ ∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) observed result * contactPotential result.2 endpoint :=
+      ENNReal.tsum_le_tsum fun result => mul_le_mul' le_rfl (contactPotential_dominates result.2 endpoint)
+    _ ≤ (queryCount observed : ENNReal) / Fintype.card State + (2 / Fintype.card State) *
+        ∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) observed result * (result.1.2 : ENNReal) :=
+      h.trans (_root_.add_le_add hinit le_rfl)
+    _ = _ := by
+      simp only [Nat.cast_add, Nat.cast_mul, Nat.cast_ofNat, expectation_add, expectation_const, expectation_scale, div_eq_mul_inv]
+      ring
+
+theorem run_contact_charge_transfer (auxiliary : QueryImpl auxSpec PMF)
+    (computation : OracleComp (auxSpec + PrefixSpec n State) Result) (observed : Fin n → State → Option State)
+    (endpoint : State) (hc : ¬Contact observed endpoint) (budget : Nat)
+    (hbudget : ∀ result ∈ (lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) observed).support,
+      queryCount result.2 ≤ budget) :
+    (1 - (budget : ENNReal) / Fintype.card State) * ((Fintype.card State : ENNReal) *
+      ∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) observed result *
+        (meanPreimages result.2 endpoint * (if Contact result.2 endpoint then 1 else 0))) ≤
+      ∑' tables, completeTables observed tables * ∑' result,
+        observedRun auxiliary tables (QueryCap.counted IsPrefixQuery computation) observed result *
+          ((EndpointPreimageDensity.preimages evaluate tables endpoint : ENNReal) *
+            ((queryCount observed + 2 * result.1.2 : Nat) : ENNReal)) := by
+  have hcard : (Fintype.card State : ENNReal) ≠ 0 := by exact_mod_cast Fintype.card_ne_zero
+  have hcharge := mul_le_mul' (le_refl (Fintype.card State : ENNReal))
+    (lazyRun_contact_charge auxiliary computation observed endpoint hc)
+  simp only [div_eq_mul_inv, mul_left_comm (Fintype.card State : ENNReal),
+    ENNReal.mul_inv_cancel hcard (by finiteness), mul_one] at hcharge
+  apply (mul_le_mul' (le_refl (1 - (budget : ENNReal) / Fintype.card State)) hcharge).trans
+  exact run_allocated_cost_lower auxiliary (QueryCap.counted IsPrefixQuery computation) observed endpoint
+    (fun result => ((queryCount observed + 2 * result.1.2 : Nat) : ENNReal)) budget hbudget
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainSupport.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainSupport.lean
new file mode 100644
index 000000000..511d320ac
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainSupport.lean
@@ -0,0 +1,35 @@
+import SphincsSecurity.Proof.Chains.AdaptiveChainEndpoint
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec ENNReal
+set_option backward.isDefEq.respectTransparency false
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+  {AuxIndex : Type} {auxSpec : OracleSpec AuxIndex} {n : Nat} {Result : Type}
+
+theorem realRun_empty_apply_lower (auxiliary : State → QueryImpl auxSpec PMF)
+    (computation : State → OracleComp (auxSpec + PrefixSpec n State) Result) (budget : Nat)
+    (hbound : ∀ endpoint, (computation endpoint).IsQueryBoundP IsPrefixQuery budget)
+    (result : State × (Result × (Fin n → State → Option State))) :
+    (1 - (budget : ENNReal) / Fintype.card State) * idealRun auxiliary computation (fun _ _ => none) result ≤
+      realRun auxiliary computation (fun _ _ => none) result := by
+  classical
+  have h := realRun_empty_cost_lower auxiliary computation budget hbound (fun output => if output = result then 1 else 0)
+  simpa only [mul_ite, mul_one, mul_zero, tsum_ite_eq] using h
+
+theorem idealRun_empty_support_subset (auxiliary : State → QueryImpl auxSpec PMF)
+    (computation : State → OracleComp (auxSpec + PrefixSpec n State) Result) (budget : Nat)
+    (hbound : ∀ endpoint, (computation endpoint).IsQueryBoundP IsPrefixQuery budget)
+    (hsmall : budget < Fintype.card State) :
+    (idealRun auxiliary computation (fun _ _ => none)).support ⊆
+      (realRun auxiliary computation (fun _ _ => none)).support := by
+  have hcard : (Fintype.card State : ENNReal) ≠ 0 := by exact_mod_cast Fintype.card_ne_zero
+  have hpositive : 0 < 1 - (budget : ENNReal) / Fintype.card State := by
+    apply tsub_pos_iff_lt.mpr
+    rw [ENNReal.div_lt_iff (Or.inl hcard) (Or.inl (by finiteness)), one_mul]
+    exact_mod_cast hsmall
+  intro result hresult
+  exact ne_of_gt (lt_of_lt_of_le (ENNReal.mul_pos_iff.mpr ⟨hpositive, pos_iff_ne_zero.mpr hresult⟩)
+    (realRun_empty_apply_lower auxiliary computation budget hbound result))
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainTwoEdge.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainTwoEdge.lean
new file mode 100644
index 000000000..e02667e8c
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/AdaptiveChainTwoEdge.lean
@@ -0,0 +1,126 @@
+import SphincsSecurity.Proof.Chains.PartialChainTwoEdgeCompensation
+import SphincsSecurity.Proof.Chains.AdaptiveChainCompensation
+import SphincsSecurity.Proof.Chains.AdaptiveChainCountedRows
+import SphincsSecurity.Proof.Chains.AdaptiveChainContactMoments
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+  {AuxIndex : Type} {auxSpec : OracleSpec AuxIndex} {n : Nat} {Result : Type}
+
+theorem lazyRun_twoEdge_compensation (auxiliary : QueryImpl auxSpec PMF)
+    (computation : OracleComp (auxSpec + PrefixSpec (n + 2) State) Result)
+    (observed : Fin (n + 2) → State → Option State) (spent : Nat) (endpoint : State) :
+    (twoEdgeCharge spent observed endpoint : ENNReal) / Fintype.card State +
+      (∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) observed result * twoEdgeWeight result.2 endpoint) ≤
+      twoEdgeWeight observed endpoint + ∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) observed result *
+        ((twoEdgeCharge (spent + result.1.2) result.2 endpoint : ENNReal) / Fintype.card State) := by
+  apply lazyRun_compensation auxiliary (fun used current => (twoEdgeCharge used current endpoint : ENNReal) / Fintype.card State)
+    (fun _ current => twoEdgeWeight current endpoint) ?_ ?_ computation observed spent
+  · intro input current used
+    have hn : (Fintype.card State : ENNReal) ≠ 0 := by exact_mod_cast Fintype.card_ne_zero
+    cases input with
+    | inl input =>
+        simp only [lazyImpl, StateT.run_mk, expectation_map, expectation_const, IsPrefixQuery, if_false, Nat.add_zero]
+        exact ENNReal.div_ne_top (ENNReal.natCast_ne_top _) hn
+    | inr query =>
+        simp only [lazyImpl, StateT.run_mk, expectation_map, IsPrefixQuery, if_true]
+        change (∑' answer : State, rowLaw (current query.1 query.2) answer *
+          ((twoEdgeCharge (used + 1) (record current query answer) endpoint : ENNReal) / Fintype.card State)) ≠ ⊤
+        rw [tsum_fintype]
+        apply ENNReal.sum_ne_top.mpr
+        intro answer _
+        exact ENNReal.mul_ne_top (ne_top_of_le_ne_top (by norm_num : (1 : ENNReal) ≠ ⊤) (PMF.coe_le_one _ _))
+          (ENNReal.div_ne_top (ENNReal.natCast_ne_top _) hn)
+  · intro input current used
+    cases input with
+    | inl input =>
+        simp only [lazyImpl, StateT.run_mk, expectation_map, expectation_const, IsPrefixQuery, if_false, Nat.add_zero]
+        exact le_of_eq (add_comm _ _)
+    | inr query =>
+        simp only [lazyImpl, StateT.run_mk, expectation_map, IsPrefixQuery, if_true]
+        exact twoEdge_observe_compensation used current query endpoint
+
+omit [Nonempty State] in
+theorem twoEdgeCharge_div_le (spent budget : Nat) (observed : Fin (n + 2) → State → Option State)
+    (endpoint : State) (hs : spent ≤ budget) (hq : queryCount observed ≤ spent) :
+    (twoEdgeCharge spent observed endpoint : ENNReal) / Fintype.card State ≤
+      ((3 / 2 : ENNReal) / Fintype.card State) * (spent : ENNReal) +
+        ((budget : ENNReal) / Fintype.card State) *
+          ((contactFactorial (contactCount observed endpoint) + 4 * contactCount observed endpoint : Nat) : ENNReal) := by
+  have hdouble : 2 * (twoEdgeCharge spent observed endpoint : ENNReal) ≤ 3 * (spent : ENNReal) +
+      2 * (budget : ENNReal) * ((contactFactorial (contactCount observed endpoint) + 4 * contactCount observed endpoint : Nat) : ENNReal) := by
+    exact_mod_cast (twoEdgeCharge_twice_le spent budget observed endpoint hs (hq.trans hs)).trans
+      (Nat.add_le_add_right (Nat.mul_le_mul_left 3 hq) _)
+  have hcast : (twoEdgeCharge spent observed endpoint : ENNReal) ≤ (3 / 2 : ENNReal) * (spent : ENNReal) +
+      (budget : ENNReal) * ((contactFactorial (contactCount observed endpoint) + 4 * contactCount observed endpoint : Nat) : ENNReal) := by
+    apply (ENNReal.mul_le_mul_iff_left (c := 2) (by norm_num) (by norm_num)).mp
+    have ht : (3 / 2 : ENNReal) * 2 = 3 := by
+      rw [div_eq_mul_inv, mul_assoc, ENNReal.inv_mul_cancel (by norm_num) (by norm_num), mul_one]
+    calc
+      _ = 2 * (twoEdgeCharge spent observed endpoint : ENNReal) := mul_comm _ _
+      _ ≤ _ := hdouble
+      _ = (3 / 2 * 2) * (spent : ENNReal) + 2 * (budget : ENNReal) *
+          ((contactFactorial (contactCount observed endpoint) + 4 * contactCount observed endpoint : Nat) : ENNReal) := by rw [ht]
+      _ = _ := by ring
+  have h := mul_le_mul' hcast (le_refl (Fintype.card State : ENNReal)⁻¹)
+  simpa only [div_eq_mul_inv, add_mul, mul_add, mul_assoc, mul_left_comm, mul_comm] using h
+
+theorem lazyRun_empty_twoEdge_le (auxiliary : QueryImpl auxSpec PMF)
+    (computation : OracleComp (auxSpec + PrefixSpec (n + 2) State) Result) (endpoint : State)
+    (budget : Nat) (hbound : computation.IsQueryBoundP IsPrefixQuery budget) :
+    (∑' result, lazyRun auxiliary computation (fun _ _ => none) result * twoEdgeWeight result.2 endpoint) ≤
+      (((3 / 2 : ENNReal) + 4 * ((budget : ENNReal) / Fintype.card State) +
+        2 * ((budget : ENNReal) / Fintype.card State)^2) / Fintype.card State) *
+          ∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) (fun _ _ => none) result * (result.1.2 : ENNReal) := by
+  rw [lazyRun_counted_expectation]
+  have hc := lazyRun_twoEdge_compensation auxiliary computation (fun _ _ => none) 0 endpoint
+  simp only [twoEdgeCharge_empty, Nat.cast_zero, div_eq_mul_inv, zero_mul, twoEdgeWeight_empty, zero_add] at hc
+  apply hc.trans
+  calc
+    _ ≤ ∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) (fun _ _ => none) result *
+        (((3 / 2 : ENNReal) / Fintype.card State) * (result.1.2 : ENNReal) +
+          ((budget : ENNReal) / Fintype.card State) *
+            ((contactFactorial (contactCount result.2 endpoint) + 4 * contactCount result.2 endpoint : Nat) : ENNReal)) := by
+      apply ENNReal.tsum_le_tsum
+      intro result
+      by_cases hr : result ∈ (lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) (fun _ _ => none)).support
+      · apply mul_le_mul' le_rfl
+        have hq := lazyRun_counted_queryCount_le auxiliary computation (fun _ _ => none) result hr
+        simp only [queryCount_empty, Nat.zero_add] at hq
+        exact twoEdgeCharge_div_le result.1.2 budget result.2 endpoint (lazyRun_counted_budget_le auxiliary computation _ budget hbound result hr) hq
+      · have hz : lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) (fun _ _ => none) result = 0 := not_not.mp hr
+        simp only [hz, zero_mul, le_refl]
+    _ = _ := by rw [expectation_add, expectation_scale, expectation_scale]
+    _ ≤ _ := by
+      have h := _root_.add_le_add
+        (le_refl (((3 / 2 : ENNReal) / Fintype.card State) *
+          ∑' result, lazyRun auxiliary (QueryCap.counted IsPrefixQuery computation) (fun _ _ => none) result * (result.1.2 : ENNReal)))
+        (lazyRun_empty_contact_correction auxiliary computation endpoint budget hbound)
+      apply h.trans_eq
+      simp only [div_eq_mul_inv]
+      ring
+
+theorem realRun_twoEdge_le (auxiliary : State → QueryImpl auxSpec PMF)
+    (computation : State → OracleComp (auxSpec + PrefixSpec (n + 2) State) Result)
+    (budget : Nat) (hbound : ∀ endpoint, (computation endpoint).IsQueryBoundP IsPrefixQuery budget) :
+    Pr[fun result => TwoEdge result.2.2 result.1 | realRun auxiliary computation (fun _ _ => none)] ≤
+      (((3 / 2 : ENNReal) + 4 * ((budget : ENNReal) / Fintype.card State) +
+        2 * ((budget : ENNReal) / Fintype.card State)^2) / Fintype.card State) *
+          ∑' result, idealRun auxiliary (fun endpoint => QueryCap.counted IsPrefixQuery (computation endpoint))
+            (fun _ _ => none) result * (result.2.1.2 : ENNReal) := by
+  rw [show Pr[fun result => TwoEdge result.2.2 result.1 | realRun auxiliary computation (fun _ _ => none)] =
+      (∑' result, realRun auxiliary computation (fun _ _ => none) result * (if TwoEdge result.2.2 result.1 then 1 else 0)) by
+        simp only [probEvent_eq_tsum_ite, PMF.probOutput_eq_apply, mul_ite, mul_one, mul_zero]]
+  rw [realRun_expectation]
+  simp only [idealRun, expectation_bind, expectation_map]
+  rw [← expectation_scale]
+  apply ENNReal.tsum_le_tsum
+  intro endpoint
+  apply mul_le_mul' le_rfl
+  exact lazyRun_empty_twoEdge_le (auxiliary endpoint) (computation endpoint) endpoint budget (hbound endpoint)
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/EndpointPreimageDensity.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/EndpointPreimageDensity.lean
new file mode 100644
index 000000000..e7ffa97d5
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/EndpointPreimageDensity.lean
@@ -0,0 +1,95 @@
+import SphincsSecurity.Proof.Base.Prelude
+namespace SphincsSecurity.Concrete.EndpointPreimageDensity
+
+open _root_.OracleComp ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+variable {Table State : Type} [Fintype State] [Nonempty State] [DecidableEq State] [DecidableEq Table]
+
+noncomputable def preimages (evaluate : Table → State → State) (table : Table) (endpoint : State) : Nat :=
+  (Finset.univ.filter (fun secret => evaluate table secret = endpoint)).card
+
+noncomputable def real (prior : PMF Table) (evaluate : Table → State → State) : PMF (Table × State) :=
+  prior.bind (fun table => ((PMF.uniformOfFintype State).map (evaluate table)).map (fun endpoint => (table, endpoint)))
+
+noncomputable def ideal (prior : PMF Table) : PMF (Table × State) :=
+  prior.bind (fun table => (PMF.uniformOfFintype State).map (fun endpoint => (table, endpoint)))
+
+theorem uniform_image_apply (evaluate : State → State) (endpoint : State) :
+    (PMF.uniformOfFintype State).map evaluate endpoint =
+      ((Finset.univ.filter (fun secret => evaluate secret = endpoint)).card : ENNReal) / Fintype.card State := by
+  rw [PMF.map_apply, tsum_fintype]
+  simp only [PMF.uniformOfFintype_apply, eq_comm, ← Finset.sum_filter]
+  simp only [Finset.sum_const, nsmul_eq_mul, div_eq_mul_inv]
+
+omit [Fintype State] [Nonempty State] [DecidableEq State] in
+theorem map_pair_apply (law : PMF State) (table target : Table) (endpoint : State) :
+    law.map (fun value => (table, value)) (target, endpoint) = if table = target then law endpoint else 0 := by
+  rw [PMF.map_apply]
+  by_cases htable : table = target
+  · subst target
+    rw [if_pos rfl, tsum_eq_single endpoint]
+    · rw [if_pos rfl]
+    · intro value hvalue
+      exact if_neg (fun h => hvalue (congrArg Prod.snd h).symm)
+  · rw [if_neg htable]
+    apply ENNReal.tsum_eq_zero.mpr
+    intro value
+    exact if_neg (fun h => htable (congrArg Prod.fst h).symm)
+
+omit [Fintype State] [Nonempty State] [DecidableEq State] in
+theorem bind_pair_apply (prior : PMF Table) (law : Table → PMF State) (table : Table) (endpoint : State) :
+    prior.bind (fun selected => (law selected).map (fun value => (selected, value))) (table, endpoint) =
+      prior table * law table endpoint := by
+  rw [PMF.bind_apply]
+  simp only [map_pair_apply, mul_ite, mul_zero]
+  rw [tsum_eq_single table]
+  · simp only [if_true]
+  · intro selected hselected
+    exact if_neg hselected
+
+theorem real_apply (prior : PMF Table) (evaluate : Table → State → State) (table : Table) (endpoint : State) :
+    real prior evaluate (table, endpoint) = prior table * ((preimages evaluate table endpoint : ENNReal) / Fintype.card State) := by
+  rw [real, bind_pair_apply, uniform_image_apply]
+  rfl
+
+omit [DecidableEq State] in
+theorem ideal_apply (prior : PMF Table) (table : Table) (endpoint : State) :
+    ideal prior (table, endpoint) = prior table / Fintype.card State := by
+  rw [ideal, bind_pair_apply, PMF.uniformOfFintype_apply, div_eq_mul_inv]
+
+theorem real_density (prior : PMF Table) (evaluate : Table → State → State) (table : Table) (endpoint : State) :
+    real prior evaluate (table, endpoint) = (preimages evaluate table endpoint : ENNReal) * ideal prior (table, endpoint) := by
+  rw [real_apply, ideal_apply]
+  simp only [div_eq_mul_inv]
+  ring
+
+theorem real_payoff (prior : PMF Table) (evaluate : Table → State → State) (payoff : Table × State → ENNReal) :
+    (∑' result, real prior evaluate result * payoff result) =
+      ∑' result : Table × State, ideal prior result * (preimages evaluate result.1 result.2 : ENNReal) * payoff result := by
+  apply tsum_congr
+  rintro ⟨table, endpoint⟩
+  rw [real_density]
+  ring
+
+omit [DecidableEq Table] in
+theorem mean_preimages (prior : PMF Table) (evaluate : Table → State → State) (endpoint : State) :
+    (∑' table, prior table * (preimages evaluate table endpoint : ENNReal)) =
+      (Fintype.card State : ENNReal) *
+        prior.bind (fun table => (PMF.uniformOfFintype State).map (evaluate table)) endpoint := by
+  have hcard : (Fintype.card State : ENNReal) ≠ 0 := by exact_mod_cast Fintype.card_ne_zero
+  rw [PMF.bind_apply, ← ENNReal.tsum_mul_left]
+  apply tsum_congr
+  intro table
+  rw [uniform_image_apply]
+  change prior table * (preimages evaluate table endpoint : ENNReal) =
+    (Fintype.card State : ENNReal) * (prior table * ((preimages evaluate table endpoint : ENNReal) / Fintype.card State))
+  rw [div_eq_mul_inv]
+  calc
+    _ = ((Fintype.card State : ENNReal) * (Fintype.card State : ENNReal)⁻¹) *
+        (prior table * (preimages evaluate table endpoint : ENNReal)) := by
+      rw [ENNReal.mul_inv_cancel hcard (by finiteness), one_mul]
+    _ = _ := by ring
+
+end SphincsSecurity.Concrete.EndpointPreimageDensity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainCompletion.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainCompletion.lean
new file mode 100644
index 000000000..4cd0dd042
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainCompletion.lean
@@ -0,0 +1,158 @@
+import SphincsSecurity.Proof.Chains.PartialChainSuffix
+import SphincsSecurity.Proof.Chains.AdaptiveChainQueryBound
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {State : Type} [Fintype State] [DecidableEq State]
+
+def Extends {n : Nat} (before after : Fin n → State → Option State) : Prop :=
+  ∀ step input answer, before step input = some answer → after step input = some answer
+
+omit [Fintype State] [DecidableEq State] in
+theorem Extends.tail {n : Nat} {before after : Fin (n + 1) → State → Option State} (h : Extends before after) :
+    Extends (Fin.tail before) (Fin.tail after) := fun step input answer => h step.succ input answer
+
+omit [Fintype State] [DecidableEq State] in
+theorem knownRun_mono {n : Nat} {before after : Fin n → State → Option State} (h : Extends before after)
+    (start endpoint : State) (hknown : knownRun before start = some endpoint) : knownRun after start = some endpoint := by
+  induction n generalizing start with
+  | zero => exact hknown
+  | succ n ih =>
+      rw [knownRun, Option.bind_eq_some_iff] at hknown ⊢
+      obtain ⟨value, hvalue, hknown⟩ := hknown
+      exact ⟨value, h 0 start value hvalue, ih h.tail value hknown⟩
+
+theorem knownCount_mono {n : Nat} {before after : Fin n → State → Option State} (h : Extends before after) (endpoint : State) :
+    knownCount before endpoint ≤ knownCount after endpoint := by
+  apply Finset.sum_le_sum
+  intro start _
+  by_cases hknown : knownRun before start = some endpoint
+  · simp only [if_pos hknown, if_pos (knownRun_mono h start endpoint hknown), le_refl]
+  · simp only [if_neg hknown, Nat.zero_le]
+
+noncomputable def targetCount : {n : Nat} → (Fin n → State → Option State) → State → Nat
+  | 0, _, _ => 0
+  | _ + 1, observed, endpoint => knownCount observed endpoint + targetCount (Fin.tail observed) endpoint
+
+noncomputable def completedCount {n : Nat} (observed : Fin n → State → Option State) : Nat :=
+  ∑ endpoint : State, targetCount observed endpoint
+
+noncomputable def pendingCount {n : Nat} (observed : Fin n → State → Option State) : Nat :=
+  queryCount observed - completedCount observed
+
+theorem suffixCount_eq_targetCount {n : Nat} (observed : Fin n → State → Option State) (endpoint : State) :
+    knownCount observed endpoint + properSuffixCount observed endpoint = 1 + targetCount observed endpoint := by
+  induction n with
+  | zero => simp only [knownCount_empty, properSuffixCount, targetCount, Nat.add_zero]
+  | succ n ih =>
+      rw [properSuffixCount, targetCount, ih]
+      omega
+
+theorem targetCount_eq_zero_of_no_contact {n : Nat} (observed : Fin n → State → Option State) (endpoint : State)
+    (h : ¬Contact observed endpoint) : targetCount observed endpoint = 0 := by
+  have hbound := suffixCount_le_one_of_no_contact observed endpoint h
+  rw [suffixCount_eq_targetCount] at hbound
+  omega
+
+theorem targetCount_mono {n : Nat} {before after : Fin n → State → Option State} (h : Extends before after) (endpoint : State) :
+    targetCount before endpoint ≤ targetCount after endpoint := by
+  induction n with
+  | zero => exact le_refl _
+  | succ n ih => exact Nat.add_le_add (knownCount_mono h endpoint) (ih h.tail)
+
+theorem completedCount_mono {n : Nat} {before after : Fin n → State → Option State} (h : Extends before after) :
+    completedCount before ≤ completedCount after :=
+  Finset.sum_le_sum fun endpoint _ => targetCount_mono h endpoint
+
+omit [DecidableEq State] in
+theorem queriedCount_eq_sum (observed : State → Option State) :
+    queriedCount observed = ∑ input : State, if observed input = none then 0 else 1 := by
+  rw [queriedCount, unqueried, Finset.card_filter]
+  have hsplit : (∑ input : State, if observed input = none then 1 else 0) +
+      (∑ input : State, if observed input = none then 0 else 1) = Fintype.card State := by
+    rw [← Finset.sum_add_distrib]
+    simp only [ite_add_ite, Nat.add_zero, Nat.zero_add, ite_self, Finset.sum_const, Finset.card_univ, smul_eq_mul, mul_one]
+  omega
+
+theorem knownCount_sum {n : Nat} (observed : Fin n → State → Option State) :
+    (∑ endpoint : State, knownCount observed endpoint) = ∑ start : State, if (knownRun observed start).isSome then 1 else 0 := by
+  simp only [knownCount]
+  rw [Finset.sum_comm]
+  apply Finset.sum_congr rfl
+  intro start _
+  cases knownRun observed start <;> simp
+
+theorem knownCount_sum_le_queried {n : Nat} (observed : Fin (n + 1) → State → Option State) :
+    (∑ endpoint : State, knownCount observed endpoint) ≤ queriedCount (observed 0) := by
+  rw [knownCount_sum, queriedCount_eq_sum]
+  apply Finset.sum_le_sum
+  intro start _
+  cases hrow : observed 0 start with
+  | none => simp [knownRun, hrow]
+  | some value =>
+      simp only [reduceCtorEq, if_false]
+      split <;> omega
+
+theorem completedCount_le_queryCount {n : Nat} (observed : Fin n → State → Option State) :
+    completedCount observed ≤ queryCount observed := by
+  induction n with
+  | zero => simp [completedCount, targetCount, queryCount]
+  | succ n ih =>
+      simp only [completedCount, targetCount, Finset.sum_add_distrib, queryCount, Fin.sum_univ_succ]
+      exact Nat.add_le_add (knownCount_sum_le_queried observed) (ih (Fin.tail observed))
+
+theorem pendingCount_partition {n : Nat} (observed : Fin n → State → Option State) :
+    pendingCount observed + completedCount observed = queryCount observed :=
+  Nat.sub_add_cancel (completedCount_le_queryCount observed)
+
+omit [Fintype State] in
+theorem record_extends {n : Nat} (observed : Fin n → State → Option State) (query : Fin n × State) (answer : State)
+    (hconsistent : observed query.1 query.2 = none ∨ observed query.1 query.2 = some answer) :
+    Extends observed (record observed query answer) := by
+  intro step input old hold
+  by_cases hstep : step = query.1
+  · subst step
+    by_cases hinput : input = query.2
+    · subst input
+      have heq : old = answer := by rcases hconsistent with h | h <;> simp_all
+      simp [record, heq]
+    · simpa only [record, Function.update_self, Function.update_of_ne hinput] using hold
+  · simpa only [record, Function.update_of_ne hstep] using hold
+
+theorem pendingCount_record_le {n : Nat} (observed : Fin n → State → Option State) (query : Fin n × State) (answer : State)
+    (hconsistent : observed query.1 query.2 = none ∨ observed query.1 query.2 = some answer) :
+    pendingCount (record observed query answer) ≤ pendingCount observed + 1 := by
+  have hbefore := pendingCount_partition observed
+  have hafter := pendingCount_partition (record observed query answer)
+  have htotal := queryCount_record_le observed query answer
+  have hdone := completedCount_mono (record_extends observed query answer hconsistent)
+  omega
+
+theorem completedCount_add_target_le {n : Nat} {before after : Fin n → State → Option State} (h : Extends before after)
+    (endpoint : State) (hcontact : ¬Contact before endpoint) :
+    completedCount before + targetCount after endpoint ≤ completedCount after := by
+  have hzero := targetCount_eq_zero_of_no_contact before endpoint hcontact
+  have hrest := Finset.sum_le_sum (s := Finset.univ.erase endpoint) fun other _ => targetCount_mono h other
+  rw [completedCount, completedCount,
+    ← Finset.add_sum_erase Finset.univ (fun other => targetCount before other) (Finset.mem_univ endpoint),
+    ← Finset.add_sum_erase Finset.univ (fun other => targetCount after other) (Finset.mem_univ endpoint), hzero]
+  omega
+
+theorem first_contact_density_charge [Nonempty State] {n : Nat} (observed : Fin n → State → Option State)
+    (query : Fin n × State) (answer endpoint : State) (hcontact : ¬Contact observed endpoint)
+    (hconsistent : observed query.1 query.2 = none ∨ observed query.1 query.2 = some answer) :
+    meanPreimages (record observed query answer) endpoint + (pendingCount (record observed query answer) : ENNReal) ≤
+      (pendingCount observed + 2 : Nat) := by
+  have hbefore := pendingCount_partition observed
+  have hafter := pendingCount_partition (record observed query answer)
+  have htotal := queryCount_record_le observed query answer
+  have hdone := completedCount_add_target_le (record_extends observed query answer hconsistent) endpoint hcontact
+  have hcount : 1 + targetCount (record observed query answer) endpoint + pendingCount (record observed query answer) ≤
+      pendingCount observed + 2 := by omega
+  have hdensity := meanPreimages_le_suffixCount (record observed query answer) endpoint
+  rw [suffixCount_eq_targetCount] at hdensity
+  exact (_root_.add_le_add hdensity le_rfl).trans (by exact_mod_cast hcount)
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainContactCount.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainContactCount.lean
new file mode 100644
index 000000000..2a8a0f24f
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainContactCount.lean
@@ -0,0 +1,111 @@
+import SphincsSecurity.Proof.Chains.PartialChainLastRow
+import SphincsSecurity.Proof.Chains.AdaptiveChainPotential
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {State : Type} [Fintype State] [DecidableEq State]
+
+noncomputable def contactCount {n : Nat} (observed : Fin n → State → Option State) (endpoint : State) : Nat :=
+  ∑ query : Fin n × State, if query.1.val + 1 = n ∧ observed query.1 query.2 = some endpoint then 1 else 0
+
+theorem contactCount_empty {n : Nat} (endpoint : State) : contactCount (n := n) (fun _ _ => none) endpoint = 0 := by
+  simp [contactCount]
+
+theorem contactCount_succ {n : Nat} (observed : Fin (n + 1) → State → Option State) (endpoint : State) :
+    contactCount observed endpoint = ∑ input : State, if observed (Fin.last n) input = some endpoint then 1 else 0 := by
+  rw [contactCount, Fintype.sum_prod_type]
+  rw [Finset.sum_eq_single (Fin.last n)]
+  · simp only [Fin.val_last, true_and]
+  · intro step _ hstep
+    have hn : step.val + 1 ≠ n + 1 := by
+      intro hn
+      apply hstep
+      apply Fin.ext
+      simp only [Fin.val_last]
+      omega
+    simp only [hn, false_and, if_false, Finset.sum_const_zero]
+  · simp
+
+theorem contactCount_tail {n : Nat} (observed : Fin (n + 2) → State → Option State) (endpoint : State) :
+    contactCount (Fin.tail observed) endpoint = contactCount observed endpoint := by
+  simp only [contactCount_succ, Fin.tail, Fin.succ_last]
+
+theorem contactCount_single (observed : Fin 1 → State → Option State) (endpoint : State) :
+    contactCount observed endpoint = knownCount observed endpoint := by
+  rw [contactCount_succ, knownCount]
+  apply Finset.sum_congr rfl
+  intro input _
+  cases hrow : observed 0 input <;> simp [knownRun, hrow]
+
+omit [Fintype State] in
+theorem record_at_other {n : Nat} (observed : Fin n → State → Option State) (query other : Fin n × State)
+    (answer : State) (h : other ≠ query) : record observed query answer other.1 other.2 = observed other.1 other.2 := by
+  by_cases hs : other.1 = query.1
+  · have hi : other.2 ≠ query.2 := fun heq => h (Prod.ext hs heq)
+    simp only [record, hs, Function.update_self, Function.update_of_ne hi]
+  · simp only [record, Function.update_of_ne hs]
+
+theorem contactCount_record_fresh {n : Nat} (observed : Fin n → State → Option State) (query : Fin n × State)
+    (answer endpoint : State) (hfresh : observed query.1 query.2 = none) :
+    contactCount (record observed query answer) endpoint =
+      contactCount observed endpoint + if query.1.val + 1 = n ∧ answer = endpoint then 1 else 0 := by
+  have hfun : (fun other : Fin n × State =>
+      if other.1.val + 1 = n ∧ record observed query answer other.1 other.2 = some endpoint then 1 else 0) =
+      Function.update (fun other : Fin n × State => if other.1.val + 1 = n ∧ observed other.1 other.2 = some endpoint then 1 else 0)
+        query (if query.1.val + 1 = n ∧ answer = endpoint then 1 else 0) := by
+    funext other
+    by_cases ho : other = query
+    · subst other
+      simp only [record, Function.update_self, Option.some.injEq]
+    · simp only [record_at_other observed query other answer ho, Function.update_of_ne ho]
+  rw [contactCount, hfun, Finset.sum_update_of_mem (Finset.mem_univ query), Finset.sdiff_singleton_eq_erase,
+    contactCount, ← Finset.add_sum_erase Finset.univ
+      (fun other : Fin n × State => if other.1.val + 1 = n ∧ observed other.1 other.2 = some endpoint then 1 else 0)
+      (Finset.mem_univ query)]
+  simp only [hfresh, reduceCtorEq, and_false, if_false, Nat.zero_add, Nat.add_comm]
+
+theorem contactCount_observe_increment_le [Nonempty State] {n : Nat}
+    (value increment : Nat → ENNReal) (hincrement : ∀ k, value (k + 1) = value k + increment k)
+    (observed : Fin n → State → Option State) (query : Fin n × State) (endpoint : State) :
+    (∑' answer, rowLaw (observed query.1 query.2) answer * value (contactCount (record observed query answer) endpoint)) ≤
+      value (contactCount observed endpoint) + increment (contactCount observed endpoint) / Fintype.card State := by
+  cases hrow : observed query.1 query.2 with
+  | some answer =>
+      simp only [rowLaw, expectation_pure, record_of_known observed query answer hrow]
+      exact _root_.le_add_of_nonneg_right bot_le
+  | none =>
+      simp only [rowLaw, contactCount_record_fresh observed query _ endpoint hrow]
+      by_cases hlast : query.1.val + 1 = n
+      · simp only [hlast, true_and]
+        have hvalue (answer : State) : value (contactCount observed endpoint + if answer = endpoint then 1 else 0) =
+            value (contactCount observed endpoint) + if answer = endpoint then increment (contactCount observed endpoint) else 0 := by
+          by_cases heq : answer = endpoint <;> simp only [heq, if_true, if_false, hincrement, add_zero]
+        simp only [hvalue, expectation_add, expectation_const]
+        simp only [mul_ite, mul_zero, tsum_ite_eq, PMF.uniformOfFintype_apply]
+        exact le_of_eq (by rw [div_eq_mul_inv, mul_comm])
+      · simp only [hlast, false_and, if_false, Nat.add_zero, expectation_const]
+        exact _root_.le_add_of_nonneg_right bot_le
+
+theorem contactCount_observe_le [Nonempty State] {n : Nat} (observed : Fin n → State → Option State)
+    (query : Fin n × State) (endpoint : State) :
+    (∑' answer, rowLaw (observed query.1 query.2) answer * (contactCount (record observed query answer) endpoint : ENNReal)) ≤
+      (contactCount observed endpoint : ENNReal) + 1 / Fintype.card State :=
+  contactCount_observe_increment_le (fun k => k) (fun _ => 1) (fun k => by simp only [Nat.cast_add, Nat.cast_one]) observed query endpoint
+
+def contactFactorial (k : Nat) : Nat := k * (k - 1)
+
+theorem contactFactorial_succ (k : Nat) : contactFactorial (k + 1) = contactFactorial k + 2 * k := by
+  cases k with
+  | zero => rfl
+  | succ k => simp only [contactFactorial, Nat.add_sub_cancel]; ring
+
+theorem contactFactorial_observe_le [Nonempty State] {n : Nat} (observed : Fin n → State → Option State)
+    (query : Fin n × State) (endpoint : State) :
+    (∑' answer, rowLaw (observed query.1 query.2) answer * (contactFactorial (contactCount (record observed query answer) endpoint) : ENNReal)) ≤
+      (contactFactorial (contactCount observed endpoint) : ENNReal) + (2 * contactCount observed endpoint : Nat) / (Fintype.card State : ENNReal) :=
+  contactCount_observe_increment_le (fun k => contactFactorial k) (fun k => (2 * k : Nat))
+    (fun k => by rw [contactFactorial_succ, Nat.cast_add]) observed query endpoint
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainContactPotential.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainContactPotential.lean
new file mode 100644
index 000000000..f4d1777cd
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainContactPotential.lean
@@ -0,0 +1,88 @@
+import SphincsSecurity.Proof.Chains.PartialChainLastRow
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+
+noncomputable def contactPotential {n : Nat} (observed : Fin n → State → Option State) (endpoint : State) : ENNReal :=
+  if Contact observed endpoint then meanPreimages observed endpoint else (pendingCount observed : ENNReal) / Fintype.card State
+
+theorem contactPotential_dominates {n : Nat} (observed : Fin n → State → Option State) (endpoint : State) :
+    meanPreimages observed endpoint * (if Contact observed endpoint then 1 else 0) ≤ contactPotential observed endpoint := by
+  by_cases h : Contact observed endpoint <;> simp [contactPotential, h]
+
+theorem contactPotential_empty {n : Nat} (endpoint : State) : contactPotential (n := n) (fun _ _ => none) endpoint = 0 := by
+  simp [contactPotential, Contact, pendingCount, queryCount_empty]
+
+theorem contactPotential_observe_of_contact {n : Nat} (observed : Fin n → State → Option State)
+    (query : Fin n × State) (endpoint : State) (hc : Contact observed endpoint) :
+    (∑' answer, rowLaw (observed query.1 query.2) answer * contactPotential (record observed query answer) endpoint) =
+      contactPotential observed endpoint := by
+  rw [contactPotential, if_pos hc, ← meanPreimages_observe observed query endpoint]
+  apply tsum_congr
+  intro answer
+  cases hrow : observed query.1 query.2 with
+  | none =>
+      rw [contactPotential, if_pos (contact_mono (record_extends observed query answer (Or.inl hrow)) endpoint hc)]
+  | some value =>
+      by_cases hanswer : answer = value
+      · subst answer
+        rw [contactPotential, if_pos (contact_mono (record_extends observed query value (Or.inr hrow)) endpoint hc)]
+      · simp only [rowLaw, PMF.pure_apply, if_neg hanswer, zero_mul]
+
+theorem contactPotential_observe_le {n : Nat} (observed : Fin n → State → Option State)
+    (query : Fin n × State) (endpoint : State) :
+    (∑' answer, rowLaw (observed query.1 query.2) answer * contactPotential (record observed query answer) endpoint) ≤
+      contactPotential observed endpoint + 2 / Fintype.card State := by
+  by_cases hc : Contact observed endpoint
+  · rw [contactPotential_observe_of_contact observed query endpoint hc]
+    exact _root_.le_add_of_nonneg_right bot_le
+  cases hrow : observed query.1 query.2 with
+  | some value =>
+      simp only [rowLaw]
+      have hpure := tsum_probOutput_pure_mul (m := PMF) value
+        (fun answer => contactPotential (record observed query answer) endpoint)
+      simp only [PMF.probOutput_eq_apply, PMF.monad_pure_eq_pure, record_of_known observed query value hrow] at hpure
+      rw [hpure]
+      exact _root_.le_add_of_nonneg_right bot_le
+  | none =>
+      by_cases hlast : query.1.val + 1 = n
+      · calc
+          _ ≤ ∑' answer, rowLaw none answer *
+              ((if answer = endpoint then meanPreimages (record observed query endpoint) endpoint else 0) +
+                (pendingCount (record observed query endpoint) : ENNReal) / Fintype.card State) := by
+            apply ENNReal.tsum_le_tsum
+            intro answer
+            apply mul_le_mul' le_rfl
+            by_cases heq : answer = endpoint
+            · subst answer
+              rw [contactPotential, if_pos ((contact_record_iff observed query endpoint endpoint hc).mpr ⟨hlast, rfl⟩), if_pos rfl]
+              exact _root_.le_add_of_nonneg_right bot_le
+            · rw [contactPotential, if_neg (by simpa only [contact_record_iff observed query answer endpoint hc, hlast, true_and] using heq), if_neg heq, zero_add]
+              rw [pendingCount_record_last_answer_eq observed query hlast answer endpoint]
+          _ = (meanPreimages (record observed query endpoint) endpoint +
+                (pendingCount (record observed query endpoint) : ENNReal)) / Fintype.card State := by
+            simp only [mul_add, ENNReal.tsum_add, ENNReal.tsum_mul_right, PMF.tsum_coe, one_mul, mul_ite, mul_zero, tsum_ite_eq]
+            simp only [rowLaw, PMF.uniformOfFintype_apply, div_eq_mul_inv, mul_comm, mul_add]
+          _ ≤ (pendingCount observed + 2 : Nat) / (Fintype.card State : ENNReal) := by
+            simpa only [div_eq_mul_inv] using mul_le_mul'
+              (first_contact_density_charge observed query endpoint endpoint hc (Or.inl hrow))
+              (le_refl (Fintype.card State : ENNReal)⁻¹)
+          _ = _ := by simp only [contactPotential, if_neg hc, Nat.cast_add, Nat.cast_ofNat, ENNReal.add_div]
+      · calc
+          _ ≤ ∑' answer, rowLaw none answer * ((pendingCount observed + 2 : Nat) / (Fintype.card State : ENNReal)) := by
+            apply ENNReal.tsum_le_tsum
+            intro answer
+            apply mul_le_mul' le_rfl
+            rw [contactPotential, if_neg (by simp only [contact_record_iff observed query answer endpoint hc, hlast, false_and, not_false_eq_true])]
+            have hp : pendingCount (record observed query answer) ≤ pendingCount observed + 2 :=
+              (pendingCount_record_le observed query answer (Or.inl hrow)).trans (by omega)
+            simpa only [div_eq_mul_inv] using mul_le_mul' (show (pendingCount (record observed query answer) : ENNReal) ≤ (pendingCount observed + 2 : Nat) by exact_mod_cast hp)
+              (le_refl (Fintype.card State : ENNReal)⁻¹)
+          _ = _ := by
+            simp only [ENNReal.tsum_mul_right, PMF.tsum_coe, one_mul, contactPotential, if_neg hc, Nat.cast_add, Nat.cast_ofNat, ENNReal.add_div]
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainEndpoint.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainEndpoint.lean
new file mode 100644
index 000000000..5a567ca38
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainEndpoint.lean
@@ -0,0 +1,110 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Chains.EndpointPreimageDensity
+import SphincsSecurity.Proof.Base.FinitePmfProductObservation
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+
+noncomputable def rowLaw : Option State → PMF State
+  | none => PMF.uniformOfFintype State
+  | some value => PMF.pure value
+
+noncomputable def completeFunction (observed : State → Option State) : PMF (State → State) :=
+  FinitePmfProduct.law (fun input => rowLaw (observed input))
+
+theorem completeFunction_marginal (observed : State → Option State) (input : State) :
+    (completeFunction observed).map (fun table => table input) = rowLaw (observed input) :=
+  FinitePmfProduct.marginal _ input
+
+def evaluate : {n : Nat} → (Fin n → State → State) → State → State
+  | 0, _, start => start
+  | _ + 1, tables, start => evaluate (Fin.tail tables) (tables 0 start)
+
+noncomputable def completeTables {n : Nat} (observed : Fin n → State → Option State) :
+    PMF (Fin n → State → State) := FinitePmfProduct.law (fun step => completeFunction (observed step))
+
+noncomputable def kernel : {n : Nat} → (Fin n → State → Option State) → State → PMF State
+  | 0, _, start => PMF.pure start
+  | _ + 1, observed, start => (rowLaw (observed 0 start)).bind (kernel (Fin.tail observed))
+
+theorem completeTables_evaluate {n : Nat} (observed : Fin n → State → Option State) (start : State) :
+    (completeTables observed).map (fun tables => evaluate tables start) = kernel observed start := by
+  induction n generalizing start with
+  | zero => exact PMF.map_const _ _
+  | succ n ih =>
+      rw [completeTables, FinitePmfProduct.fin_succ, PMF.map_bind]
+      simp only [PMF.map_comp, Function.comp_def, evaluate, Fin.tail_cons, Fin.cons_zero]
+      change (completeFunction (observed 0)).bind (fun first =>
+        (completeTables (Fin.tail observed)).map (fun tables => evaluate tables (first start))) = _
+      simp_rw [ih]
+      calc
+        _ = ((completeFunction (observed 0)).map (fun first => first start)).bind (kernel (Fin.tail observed)) :=
+          (PMF.bind_map _ _ _).symm
+        _ = _ := by rw [completeFunction_marginal, kernel]
+
+theorem uniform_endpoint {n : Nat} (observed : Fin n → State → Option State) :
+    (completeTables observed).bind (fun tables => (PMF.uniformOfFintype State).map (evaluate tables)) =
+      (PMF.uniformOfFintype State).bind (kernel observed) := by
+  change (completeTables observed).bind (fun tables =>
+    (PMF.uniformOfFintype State).bind (fun start => PMF.pure (evaluate tables start))) = _
+  rw [PMF.bind_comm]
+  change (PMF.uniformOfFintype State).bind
+    (fun start => (completeTables observed).map (fun tables => evaluate tables start)) = _
+  simp only [completeTables_evaluate]
+
+noncomputable def meanPreimages {n : Nat} (observed : Fin n → State → Option State) (endpoint : State) : ENNReal :=
+  ∑' tables, completeTables observed tables * (EndpointPreimageDensity.preimages evaluate tables endpoint : ENNReal)
+
+theorem meanPreimages_eq {n : Nat} (observed : Fin n → State → Option State) (endpoint : State) :
+    meanPreimages observed endpoint =
+      (Fintype.card State : ENNReal) * ((PMF.uniformOfFintype State).bind (kernel observed)) endpoint := by
+  rw [meanPreimages, EndpointPreimageDensity.mean_preimages, uniform_endpoint]
+
+noncomputable def unqueried (observed : State → Option State) : Finset State :=
+  Finset.univ.filter (fun input => observed input = none)
+
+noncomputable def freeFraction (observed : State → Option State) : ENNReal :=
+  (unqueried observed).card / (Fintype.card State : ENNReal)
+
+omit [DecidableEq State] in
+theorem advance_lower (observed : State → Option State) (prior : PMF State) (bound : ENNReal)
+    (hlower : ∀ input, bound ≤ prior input) (endpoint : State) :
+    bound * freeFraction observed ≤ prior.bind (fun input => rowLaw (observed input)) endpoint := by
+  rw [PMF.bind_apply, tsum_fintype]
+  calc
+    _ = ∑ input ∈ unqueried observed, bound * (Fintype.card State : ENNReal)⁻¹ := by
+      simp only [Finset.sum_const, nsmul_eq_mul, freeFraction, div_eq_mul_inv]
+      ring
+    _ ≤ ∑ input ∈ unqueried observed, prior input * rowLaw (observed input) endpoint := by
+      apply Finset.sum_le_sum
+      intro input hinput
+      have hnone : observed input = none := (Finset.mem_filter.mp hinput).2
+      rw [hnone, rowLaw, PMF.uniformOfFintype_apply]
+      exact mul_le_mul_left (hlower input) _
+    _ ≤ _ := Finset.sum_le_sum_of_subset_of_nonneg (Finset.subset_univ _) (fun _ _ _ => bot_le)
+
+omit [DecidableEq State] in
+theorem kernel_lower {n : Nat} (observed : Fin n → State → Option State) (prior : PMF State) (bound : ENNReal)
+    (hlower : ∀ input, bound ≤ prior input) (endpoint : State) :
+    bound * (∏ step, freeFraction (observed step)) ≤ prior.bind (kernel observed) endpoint := by
+  induction n generalizing prior bound with
+  | zero => simpa only [Fin.prod_univ_zero, mul_one, kernel, PMF.bind_pure] using hlower endpoint
+  | succ n ih =>
+      rw [Fin.prod_univ_succ, ← mul_assoc]
+      have h := ih (Fin.tail observed) (prior.bind (fun input => rowLaw (observed 0 input)))
+        (bound * freeFraction (observed 0)) (advance_lower (observed 0) prior bound hlower)
+      simpa only [PMF.bind_bind, kernel, Fin.tail] using h
+
+theorem meanPreimages_ge_product {n : Nat} (observed : Fin n → State → Option State) (endpoint : State) :
+    (∏ step, freeFraction (observed step)) ≤ meanPreimages observed endpoint := by
+  have hcard : (Fintype.card State : ENNReal) ≠ 0 := by exact_mod_cast Fintype.card_ne_zero
+  rw [meanPreimages_eq]
+  have h := mul_le_mul_right (kernel_lower observed (PMF.uniformOfFintype State) (Fintype.card State : ENNReal)⁻¹
+    (fun input => by rw [PMF.uniformOfFintype_apply]) endpoint) (Fintype.card State : ENNReal)
+  simpa only [← mul_assoc, ENNReal.mul_inv_cancel hcard (by finiteness), one_mul] using h
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainLastRow.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainLastRow.lean
new file mode 100644
index 000000000..2b26b8560
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainLastRow.lean
@@ -0,0 +1,117 @@
+import SphincsSecurity.Proof.Chains.PartialChainCompletion
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {State : Type} [Fintype State] [DecidableEq State]
+
+omit [Fintype State] [DecidableEq State] in
+theorem knownRun_isSome_eq_of_last {n : Nat} (before after : Fin n → State → Option State)
+    (hearly : ∀ step input, step.val + 1 ≠ n → before step input = after step input)
+    (hlast : ∀ step input, step.val + 1 = n → (before step input).isSome = (after step input).isSome)
+    (start : State) : (knownRun before start).isSome = (knownRun after start).isSome := by
+  induction n generalizing start with
+  | zero => rfl
+  | succ n ih =>
+      cases n with
+      | zero =>
+          simpa [knownRun] using hlast 0 start rfl
+      | succ n =>
+          have hhead := hearly 0 start (by simp)
+          have htail := ih (Fin.tail before) (Fin.tail after)
+            (fun step input h => hearly step.succ input (by simpa only [Fin.val_succ, Nat.succ_add, Nat.succ_ne_succ_iff] using h))
+            (fun step input h => hlast step.succ input (by simpa only [Fin.val_succ, Nat.succ_add, Nat.succ.injEq] using h))
+          simp only [knownRun, hhead]
+          cases after 0 start with
+          | none => rfl
+          | some value => exact htail value
+
+theorem completedCount_eq_of_last {n : Nat} (before after : Fin n → State → Option State)
+    (hearly : ∀ step input, step.val + 1 ≠ n → before step input = after step input)
+    (hlast : ∀ step input, step.val + 1 = n → (before step input).isSome = (after step input).isSome) :
+    completedCount before = completedCount after := by
+  induction n with
+  | zero => rfl
+  | succ n ih =>
+      change (∑ endpoint : State, (knownCount before endpoint + targetCount (Fin.tail before) endpoint)) =
+        ∑ endpoint : State, (knownCount after endpoint + targetCount (Fin.tail after) endpoint)
+      rw [Finset.sum_add_distrib, Finset.sum_add_distrib, knownCount_sum, knownCount_sum]
+      congr 1
+      · exact Finset.sum_congr rfl fun start _ => congrArg (fun b : Bool => if b then 1 else 0)
+          (knownRun_isSome_eq_of_last before after hearly hlast start)
+      · exact ih (Fin.tail before) (Fin.tail after)
+          (fun step input h => hearly step.succ input (by simpa only [Fin.val_succ, Nat.succ_add, Nat.succ_ne_succ_iff] using h))
+          (fun step input h => hlast step.succ input (by simpa only [Fin.val_succ, Nat.succ_add, Nat.succ.injEq] using h))
+
+omit [Fintype State] in
+theorem record_isSome_eq {n : Nat} (observed : Fin n → State → Option State) (query : Fin n × State)
+    (first second : State) (step : Fin n) (input : State) :
+    (record observed query first step input).isSome = (record observed query second step input).isSome := by
+  by_cases hs : step = query.1
+  · subst step
+    by_cases hi : input = query.2
+    · subst input; simp [record]
+    · simp only [record, Function.update_self, Function.update_of_ne hi]
+  · simp only [record, Function.update_of_ne hs]
+
+theorem queryCount_record_answer_eq {n : Nat} (observed : Fin n → State → Option State) (query : Fin n × State)
+    (first second : State) : queryCount (record observed query first) = queryCount (record observed query second) := by
+  unfold queryCount
+  apply Finset.sum_congr rfl
+  intro step _
+  rw [queriedCount_eq_sum, queriedCount_eq_sum]
+  apply Finset.sum_congr rfl
+  intro input _
+  have h := record_isSome_eq observed query first second step input
+  cases hfirst : record observed query first step input <;> cases hsecond : record observed query second step input <;> simp_all
+
+theorem pendingCount_record_last_answer_eq {n : Nat} (observed : Fin n → State → Option State) (query : Fin n × State)
+    (hlast : query.1.val + 1 = n) (first second : State) :
+    pendingCount (record observed query first) = pendingCount (record observed query second) := by
+  unfold pendingCount
+  rw [queryCount_record_answer_eq observed query first second]
+  congr 1
+  apply completedCount_eq_of_last
+  · intro step input hearly
+    have hs : step ≠ query.1 := fun h => hearly (by simpa only [h] using hlast)
+    simp only [record, Function.update_of_ne hs]
+  · intro step input _
+    exact record_isSome_eq observed query first second step input
+
+omit [Fintype State] [DecidableEq State] in
+theorem contact_mono {n : Nat} {before after : Fin n → State → Option State} (h : Extends before after)
+    (endpoint : State) (hc : Contact before endpoint) : Contact after endpoint := by
+  obtain ⟨step, hstep, input, hinput⟩ := hc
+  exact ⟨step, hstep, input, h step input endpoint hinput⟩
+
+omit [Fintype State] in
+theorem contact_record_iff {n : Nat} (observed : Fin n → State → Option State) (query : Fin n × State)
+    (answer endpoint : State) (hc : ¬Contact observed endpoint) :
+    Contact (record observed query answer) endpoint ↔ query.1.val + 1 = n ∧ answer = endpoint := by
+  constructor
+  · rintro ⟨step, hstep, input, hinput⟩
+    by_cases hs : step = query.1
+    · subst step
+      by_cases hi : input = query.2
+      · subst input
+        exact ⟨hstep, by simpa only [record, Function.update_self, Option.some.injEq] using hinput⟩
+      · exact False.elim (hc ⟨query.1, hstep, input, by simpa only [record, Function.update_self, Function.update_of_ne hi] using hinput⟩)
+    · exact False.elim (hc ⟨step, hstep, input, by simpa only [record, Function.update_of_ne hs] using hinput⟩)
+  · rintro ⟨hlast, rfl⟩
+    exact ⟨query.1, hlast, query.2, by simp only [record, Function.update_self]⟩
+
+omit [Fintype State] in
+theorem record_of_known {n : Nat} (observed : Fin n → State → Option State) (query : Fin n × State)
+    (answer : State) (h : observed query.1 query.2 = some answer) : record observed query answer = observed := by
+  simp only [record, ← h, Function.update_eq_self]
+
+theorem meanPreimages_observe [Nonempty State] {n : Nat} (observed : Fin n → State → Option State)
+    (query : Fin n × State) (endpoint : State) :
+    (∑' answer, rowLaw (observed query.1 query.2) answer * meanPreimages (record observed query answer) endpoint) =
+      meanPreimages observed endpoint := by
+  simp only [meanPreimages, ← ENNReal.tsum_mul_left, ← mul_assoc, completeTables_observe_mass, ite_mul, zero_mul]
+  rw [ENNReal.tsum_comm]
+  simp
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainLikelihoodLower.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainLikelihoodLower.lean
new file mode 100644
index 000000000..8cc3c999b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainLikelihoodLower.lean
@@ -0,0 +1,82 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Chains.PartialChainEndpoint
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem one_sub_sum_le_prod {Index : Type} [DecidableEq Index] (indices : Finset Index)
+    (loss : Index → ℝ) (hlower : ∀ index ∈ indices, 0 ≤ loss index) (hupper : ∀ index ∈ indices, loss index ≤ 1) :
+    1 - ∑ index ∈ indices, loss index ≤ ∏ index ∈ indices, (1 - loss index) := by
+  induction indices using Finset.induction_on with
+  | empty => simp
+  | @insert index indices hnot ih =>
+      have hzero := hlower index (Finset.mem_insert_self _ _)
+      have hone := hupper index (Finset.mem_insert_self _ _)
+      have hsum : 0 ≤ ∑ other ∈ indices, loss other :=
+        Finset.sum_nonneg (fun other hother => hlower other (Finset.mem_insert_of_mem hother))
+      have htail := ih (fun other hother => hlower other (Finset.mem_insert_of_mem hother))
+        (fun other hother => hupper other (Finset.mem_insert_of_mem hother))
+      rw [Finset.sum_insert hnot, Finset.prod_insert hnot]
+      calc
+        _ ≤ (1 - loss index) * (1 - ∑ other ∈ indices, loss other) := by
+          nlinarith [mul_nonneg hzero hsum]
+        _ ≤ _ := mul_le_mul_of_nonneg_left htail (by linarith)
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+
+noncomputable def queriedCount (observed : State → Option State) : Nat :=
+  Fintype.card State - (unqueried observed).card
+
+noncomputable def queryCount {n : Nat} (observed : Fin n → State → Option State) : Nat :=
+  ∑ step, queriedCount (observed step)
+
+omit [DecidableEq State] [Nonempty State] in
+theorem queriedCount_le (observed : State → Option State) : queriedCount observed ≤ Fintype.card State :=
+  Nat.sub_le _ _
+
+omit [DecidableEq State] in
+theorem freeFraction_ne_top (observed : State → Option State) : freeFraction observed ≠ ⊤ := by
+  have hcard : (Fintype.card State : ENNReal) ≠ 0 := by exact_mod_cast Fintype.card_ne_zero
+  unfold freeFraction
+  finiteness
+
+omit [DecidableEq State] in
+theorem freeFraction_toReal (observed : State → Option State) :
+    (freeFraction observed).toReal = 1 - (queriedCount observed : ℝ) / Fintype.card State := by
+  have hcard : (Fintype.card State : ℝ) ≠ 0 := by exact_mod_cast Fintype.card_ne_zero
+  have hcount : (unqueried observed).card ≤ Fintype.card State := Finset.card_le_univ _
+  rw [freeFraction, ENNReal.toReal_div, ENNReal.toReal_natCast, ENNReal.toReal_natCast,
+    queriedCount, Nat.cast_sub hcount, sub_div, div_self hcard]
+  ring
+
+omit [DecidableEq State] in
+theorem product_ge_queryCount {n : Nat} (observed : Fin n → State → Option State) :
+    1 - (queryCount observed : ENNReal) / Fintype.card State ≤ ∏ step, freeFraction (observed step) := by
+  have hcard : (Fintype.card State : ENNReal) ≠ 0 := by exact_mod_cast Fintype.card_ne_zero
+  have hcardR : (0 : ℝ) < Fintype.card State := by exact_mod_cast Fintype.card_pos
+  by_cases hbudget : (queryCount observed : ENNReal) / Fintype.card State ≤ 1
+  · apply (ENNReal.toReal_le_toReal (by finiteness)
+      (ENNReal.prod_ne_top (fun step _ => freeFraction_ne_top (observed step)))).mp
+    rw [ENNReal.toReal_sub_of_le hbudget (by finiteness), ENNReal.toReal_one, ENNReal.toReal_div,
+      ENNReal.toReal_natCast, ENNReal.toReal_natCast]
+    simp only [ENNReal.toReal_prod, freeFraction_toReal, queryCount, Nat.cast_sum, Finset.sum_div]
+    exact one_sub_sum_le_prod Finset.univ (fun step => (queriedCount (observed step) : ℝ) / Fintype.card State)
+      (fun _ _ => by positivity)
+      (fun step _ => (div_le_one hcardR).mpr (by exact_mod_cast queriedCount_le (observed step)))
+  · rw [tsub_eq_zero_of_le (le_of_not_ge hbudget)]
+    exact bot_le
+
+theorem meanPreimages_ge_queryCount {n : Nat} (observed : Fin n → State → Option State) (endpoint : State) :
+    1 - (queryCount observed : ENNReal) / Fintype.card State ≤ meanPreimages observed endpoint :=
+  (product_ge_queryCount observed).trans (meanPreimages_ge_product observed endpoint)
+
+theorem meanPreimages_ge_budget {n : Nat} (observed : Fin n → State → Option State) (endpoint : State)
+    (budget : Nat) (hbudget : queryCount observed ≤ budget) :
+    1 - (budget : ENNReal) / Fintype.card State ≤ meanPreimages observed endpoint := by
+  apply le_trans _ (meanPreimages_ge_queryCount observed endpoint)
+  have hcount : (queryCount observed : ENNReal) ≤ (budget : ENNReal) := by exact_mod_cast hbudget
+  exact tsub_le_tsub_left (ENNReal.div_le_div_right hcount _) _
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainLongCompletion.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainLongCompletion.lean
new file mode 100644
index 000000000..0502d5c67
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainLongCompletion.lean
@@ -0,0 +1,146 @@
+import SphincsSecurity.Proof.Chains.PartialChainRowCharge
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {State : Type} [Fintype State] [DecidableEq State]
+
+noncomputable def longCompleted : {n : Nat} → (Fin n → State → Option State) → Nat
+  | 0, _ => 0
+  | 1, _ => 0
+  | _ + 2, observed => (∑ endpoint : State, knownCount observed endpoint) + longCompleted (Fin.tail observed)
+
+omit [Fintype State] [DecidableEq State] in
+theorem Extends.init {n : Nat} {before after : Fin (n + 1) → State → Option State} (h : Extends before after) :
+    Extends (Fin.init before) (Fin.init after) := fun step input answer => h step.castSucc input answer
+
+theorem longCompleted_mono {n : Nat} {before after : Fin n → State → Option State} (h : Extends before after) :
+    longCompleted before ≤ longCompleted after := by
+  induction n with
+  | zero => exact le_rfl
+  | succ n ih =>
+      cases n with
+      | zero => exact le_rfl
+      | succ n =>
+          exact Nat.add_le_add (Finset.sum_le_sum fun endpoint _ => knownCount_mono h endpoint) (ih h.tail)
+
+theorem knownCount_sum_single (observed : Fin 1 → State → Option State) :
+    (∑ endpoint : State, knownCount observed endpoint) = queriedCount (observed 0) := by
+  rw [knownCount_sum, queriedCount_eq_sum]
+  apply Finset.sum_congr rfl
+  intro input _
+  cases hrow : observed 0 input <;> simp [knownRun, hrow]
+
+theorem completedCount_eq_longCompleted {n : Nat} (observed : Fin (n + 1) → State → Option State) :
+    completedCount observed = longCompleted observed + queriedCount (observed (Fin.last n)) := by
+  induction n with
+  | zero =>
+      simp only [completedCount, targetCount, Nat.add_zero, longCompleted, Nat.zero_add]
+      exact knownCount_sum_single observed
+  | succ n ih =>
+      change (∑ endpoint : State, (knownCount observed endpoint + targetCount (Fin.tail observed) endpoint)) = _
+      rw [Finset.sum_add_distrib]
+      change (∑ endpoint : State, knownCount observed endpoint) + completedCount (Fin.tail observed) = _
+      rw [ih (Fin.tail observed)]
+      simp only [longCompleted, Fin.tail, Fin.succ_last, Nat.add_assoc]
+
+omit [DecidableEq State] in
+theorem queryCount_split_last {n : Nat} (observed : Fin (n + 1) → State → Option State) :
+    queryCount observed = queryCount (Fin.init observed) + queriedCount (observed (Fin.last n)) := by
+  simp only [queryCount, Fin.sum_univ_castSucc, Fin.init]
+
+theorem longCompleted_le_prefix_queries {n : Nat} (observed : Fin (n + 1) → State → Option State) :
+    longCompleted observed ≤ queryCount (Fin.init observed) := by
+  have h := completedCount_le_queryCount observed
+  rw [completedCount_eq_longCompleted, queryCount_split_last] at h
+  omega
+
+theorem longCompleted_le_queryCount {n : Nat} (observed : Fin n → State → Option State) :
+    longCompleted observed ≤ queryCount observed := by
+  cases n with
+  | zero => exact Nat.zero_le _
+  | succ n =>
+      have h := longCompleted_le_prefix_queries observed
+      rw [queryCount_split_last]
+      omega
+
+theorem longCompleted_empty {n : Nat} : longCompleted (fun (_ : Fin n) (_ : State) => none) = 0 := by
+  have h := longCompleted_le_queryCount (fun (_ : Fin n) (_ : State) => none)
+  rw [queryCount_empty] at h
+  omega
+
+omit [Fintype State] [DecidableEq State] in
+theorem tail_snoc {n : Nat} (before : Fin (n + 1) → State → Option State) (last : State → Option State) :
+    @Fin.tail (n + 1) (fun _ => State → Option State) (Fin.snoc before last) =
+      (Fin.snoc (Fin.tail before) last : Fin (n + 1) → State → Option State) := by
+  have hs : Fin.snoc before last = @Fin.cons (n + 1) (fun _ => State → Option State) (before 0) (Fin.snoc (Fin.tail before) last) := by
+    rw [Fin.cons_snoc_eq_snoc_cons, Fin.cons_self_tail]
+  rw [hs, Fin.tail_cons]
+
+omit [Fintype State] [DecidableEq State] in
+theorem knownRun_snoc {n : Nat} (before : Fin n → State → Option State) (last : State → Option State) :
+    knownRun (Fin.snoc before last) = fun start => (knownRun before start).bind last := by
+  induction n with
+  | zero => funext start; simp [knownRun, Fin.snoc_zero]
+  | succ n ih =>
+      funext start
+      have hs : Fin.snoc before last = @Fin.cons (n + 1) (fun _ => State → Option State) (before 0) (Fin.snoc (Fin.tail before) last) := by
+        rw [Fin.cons_snoc_eq_snoc_cons, Fin.cons_self_tail]
+      rw [hs, knownRun, Fin.cons_zero, Fin.tail_cons, ih]
+      simp only [knownRun, Option.bind_assoc]
+
+theorem knownCount_sum_last_fresh {n : Nat} (before : Fin n → State → Option State) (last : State → Option State)
+    (input answer : State) (hfresh : last input = none) :
+    (∑ endpoint : State, knownCount (Fin.snoc before (Function.update last input (some answer))) endpoint) =
+      (∑ endpoint : State, knownCount (Fin.snoc before last) endpoint) + knownCount before input := by
+  rw [knownCount_sum, knownCount_sum]
+  simp only [knownCount, ← Finset.sum_add_distrib, knownRun_snoc]
+  apply Finset.sum_congr rfl
+  intro start _
+  cases hrun : knownRun before start with
+  | none => simp only [Option.bind_none, Option.isSome_none, Bool.false_eq_true, if_false, reduceCtorEq, Nat.add_zero]
+  | some value =>
+      by_cases hv : value = input
+      · subst value
+        simp only [Option.bind_some, Function.update_self, hfresh, Option.isSome_some, Option.isSome_none,
+          Bool.false_eq_true, if_true, if_false, Nat.zero_add]
+      · simp only [Option.bind_some, Function.update_of_ne hv, Option.some.injEq, if_neg hv, Nat.add_zero]
+
+theorem longCompleted_last_fresh {n : Nat} (before : Fin n → State → Option State) (last : State → Option State)
+    (input answer : State) (hfresh : last input = none) :
+    longCompleted (Fin.snoc before (Function.update last input (some answer))) =
+      longCompleted (Fin.snoc before last) + targetCount before input := by
+  induction n with
+  | zero => simp only [longCompleted, targetCount, Nat.add_zero]
+  | succ n ih =>
+      rw [longCompleted, longCompleted, tail_snoc, tail_snoc, knownCount_sum_last_fresh before last input answer hfresh,
+        ih (Fin.tail before), targetCount]
+      omega
+
+theorem longCompleted_record_last {n : Nat} (observed : Fin (n + 1) → State → Option State)
+    (input answer : State) (hfresh : observed (Fin.last n) input = none) :
+    longCompleted (record observed (Fin.last n, input) answer) =
+      longCompleted observed + targetCount (Fin.init observed) input := by
+  have h := longCompleted_last_fresh (Fin.init observed) (observed (Fin.last n)) input answer hfresh
+  rw [Fin.snoc_init_self] at h
+  have hrecord : record observed (Fin.last n, input) answer =
+      Fin.snoc (Fin.init observed) (Function.update (observed (Fin.last n)) input (some answer)) := by
+    conv_lhs => rw [← Fin.snoc_init_self observed]
+    simp only [record, Fin.snoc_last, Fin.update_snoc_last]
+  simpa only [hrecord] using h
+
+omit [Fintype State] in
+theorem init_record {n : Nat} (observed : Fin (n + 1) → State → Option State)
+    (step : Fin n) (input answer : State) :
+    Fin.init (record observed (step.castSucc, input) answer) = record (Fin.init observed) (step, input) answer := by
+  simp only [record, Fin.init_update_castSucc, Fin.init]
+
+theorem longCompleted_prefix_record_penultimate {n : Nat} (observed : Fin (n + 2) → State → Option State)
+    (input answer : State) (hfresh : observed (Fin.last n).castSucc input = none) :
+    longCompleted (Fin.init (record observed ((Fin.last n).castSucc, input) answer)) =
+      longCompleted (Fin.init observed) + targetCount (Fin.init (Fin.init observed)) input := by
+  rw [init_record]
+  exact longCompleted_record_last (Fin.init observed) input answer hfresh
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainObservation.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainObservation.lean
new file mode 100644
index 000000000..8859d0359
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainObservation.lean
@@ -0,0 +1,76 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Chains.PartialChainEndpoint
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+
+theorem completeFunction_empty :
+    completeFunction (fun (_ : State) => none) = PMF.uniformOfFintype (State → State) :=
+  FinitePmfProduct.uniform
+
+theorem completeTables_empty {n : Nat} :
+    completeTables (fun (_ : Fin n) (_ : State) => none) = PMF.uniformOfFintype (Fin n → State → State) := by
+  simp only [completeTables, completeFunction_empty, FinitePmfProduct.uniform]
+
+def record {n : Nat} (observed : Fin n → State → Option State) (query : Fin n × State) (answer : State) :
+    Fin n → State → Option State :=
+  Function.update observed query.1 (Function.update (observed query.1) query.2 (some answer))
+
+theorem completeFunction_record (observed : State → Option State) (input answer : State) :
+    completeFunction (Function.update observed input (some answer)) =
+      FinitePmfProduct.law (Function.update (fun row => rowLaw (observed row)) input (PMF.pure answer)) := by
+  unfold completeFunction
+  congr 1
+  funext row
+  by_cases hrow : row = input
+  · simp only [hrow, Function.update_self, rowLaw]
+  · simp only [Function.update_of_ne hrow]
+
+theorem completeFunction_observe_mass (observed : State → Option State) (input answer : State) (table : State → State) :
+    rowLaw (observed input) answer * completeFunction (Function.update observed input (some answer)) table =
+      if table input = answer then completeFunction observed table else 0 := by
+  rw [completeFunction_record]
+  exact FinitePmfProduct.observe_mass (fun row => rowLaw (observed row)) input answer table
+
+theorem completeTables_record {n : Nat} (observed : Fin n → State → Option State)
+    (query : Fin n × State) (answer : State) :
+    completeTables (record observed query answer) =
+      FinitePmfProduct.law (Function.update (fun step => completeFunction (observed step)) query.1
+        (completeFunction (Function.update (observed query.1) query.2 (some answer)))) := by
+  unfold completeTables record
+  congr 1
+  funext step
+  by_cases hstep : step = query.1
+  · simp only [hstep, Function.update_self]
+  · simp only [Function.update_of_ne hstep]
+
+theorem completeTables_observe_mass {n : Nat} (observed : Fin n → State → Option State)
+    (query : Fin n × State) (answer : State) (tables : Fin n → State → State) :
+    rowLaw (observed query.1 query.2) answer * completeTables (record observed query answer) tables =
+      if tables query.1 query.2 = answer then completeTables observed tables else 0 := by
+  rw [completeTables_record, FinitePmfProduct.update_apply, ← mul_assoc,
+    completeFunction_observe_mass, ite_mul, zero_mul]
+  by_cases hanswer : tables query.1 query.2 = answer
+  · rw [if_pos hanswer, if_pos hanswer, completeTables, FinitePmfProduct.apply]
+    exact Finset.mul_prod_erase Finset.univ (fun step => completeFunction (observed step) (tables step))
+      (Finset.mem_univ query.1)
+  · rw [if_neg hanswer, if_neg hanswer]
+
+theorem completeTables_bind_observe {n : Nat} {Result : Type} (observed : Fin n → State → Option State)
+    (query : Fin n × State) (next : State → (Fin n → State → State) → PMF Result) :
+    (completeTables observed).bind (fun tables => next (tables query.1 query.2) tables) =
+      (rowLaw (observed query.1 query.2)).bind (fun answer =>
+        (completeTables (record observed query answer)).bind (next answer)) := by
+  classical
+  apply PMF.ext
+  intro output
+  simp only [PMF.bind_apply, ← ENNReal.tsum_mul_left, ← mul_assoc, completeTables_observe_mass,
+    ite_mul, zero_mul]
+  rw [ENNReal.tsum_comm]
+  simp
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainPreparation.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainPreparation.lean
new file mode 100644
index 000000000..0de5ebe25
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainPreparation.lean
@@ -0,0 +1,110 @@
+import SphincsSecurity.Proof.Chains.PartialChainLongCompletion
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {State : Type} [Fintype State] [DecidableEq State]
+
+noncomputable def queriedInputs (row : State → Option State) : Finset State :=
+  Finset.univ.filter fun input => row input ≠ none
+
+noncomputable def rowImage (row : State → Option State) : Finset State :=
+  Finset.univ.biUnion fun input => (row input).toFinset
+
+omit [DecidableEq State] in
+theorem mem_queriedInputs (row : State → Option State) (input : State) :
+    input ∈ queriedInputs row ↔ row input ≠ none := by simp [queriedInputs]
+
+omit [DecidableEq State] in
+theorem queriedInputs_card (row : State → Option State) : (queriedInputs row).card = queriedCount row := by
+  rw [queriedInputs, Finset.card_filter, queriedCount_eq_sum]
+  apply Finset.sum_congr rfl
+  intro input _
+  cases row input <;> simp
+
+theorem mem_rowImage (row : State → Option State) (output : State) :
+    output ∈ rowImage row ↔ ∃ input, row input = some output := by
+  simp only [rowImage, Finset.mem_biUnion, Finset.mem_univ, true_and, Option.mem_toFinset, Option.mem_def]
+
+theorem rowImage_card_le (row : State → Option State) : (rowImage row).card ≤ queriedCount row := by
+  apply Finset.card_biUnion_le.trans
+  rw [queriedCount_eq_sum]
+  apply Finset.sum_le_sum
+  intro input _
+  cases row input <;> simp
+
+noncomputable def productiveInputs {n : Nat} (observed : Fin (n + 2) → State → Option State) : Finset State :=
+  queriedInputs (observed (Fin.last (n + 1))) ∩ rowImage (observed (Fin.last n).castSucc)
+
+noncomputable def preparationCount {n : Nat} (observed : Fin (n + 2) → State → Option State) : Nat :=
+  (productiveInputs observed).card
+
+theorem mem_productiveInputs {n : Nat} (observed : Fin (n + 2) → State → Option State) (input : State) :
+    input ∈ productiveInputs observed ↔
+      observed (Fin.last (n + 1)) input ≠ none ∧ ∃ start, observed (Fin.last n).castSucc start = some input := by
+  simp only [productiveInputs, Finset.mem_inter, mem_queriedInputs, mem_rowImage]
+
+theorem productiveInputs_mono {n : Nat} {before after : Fin (n + 2) → State → Option State} (h : Extends before after) :
+    productiveInputs before ⊆ productiveInputs after := by
+  intro input hi
+  rw [mem_productiveInputs] at hi ⊢
+  constructor
+  · cases hr : before (Fin.last (n + 1)) input with
+    | none => exact False.elim (hi.1 hr)
+    | some answer => rw [h _ _ _ hr]; exact Option.some_ne_none answer
+  · obtain ⟨start, hs⟩ := hi.2
+    exact ⟨start, h _ _ _ hs⟩
+
+theorem preparationCount_mono {n : Nat} {before after : Fin (n + 2) → State → Option State} (h : Extends before after) :
+    preparationCount before ≤ preparationCount after := Finset.card_le_card (productiveInputs_mono h)
+
+theorem preparationCount_le_last {n : Nat} (observed : Fin (n + 2) → State → Option State) :
+    preparationCount observed ≤ queriedCount (observed (Fin.last (n + 1))) := by
+  exact (Finset.card_le_card Finset.inter_subset_left).trans_eq (queriedInputs_card _)
+
+theorem preparationCount_le_penultimate {n : Nat} (observed : Fin (n + 2) → State → Option State) :
+    preparationCount observed ≤ queriedCount (observed (Fin.last n).castSucc) := by
+  exact (Finset.card_le_card Finset.inter_subset_right).trans (rowImage_card_le _)
+
+theorem preparationCount_le_prefix {n : Nat} (observed : Fin (n + 2) → State → Option State) :
+    preparationCount observed ≤ queryCount (Fin.init observed) := by
+  apply (preparationCount_le_penultimate observed).trans
+  change queriedCount ((Fin.init observed) (Fin.last n)) ≤ ∑ step, queriedCount ((Fin.init observed) step)
+  exact Finset.single_le_sum (f := fun step => queriedCount ((Fin.init observed) step))
+    (fun _ _ => Nat.zero_le _) (Finset.mem_univ (Fin.last n))
+
+theorem preparationCount_empty {n : Nat} : preparationCount (n := n) (fun (_ : Fin (n + 2)) (_ : State) => none) = 0 := by
+  simp [preparationCount, productiveInputs, queriedInputs]
+
+theorem preparationCount_last_fresh {n : Nat} (observed : Fin (n + 2) → State → Option State) (input answer : State)
+    (hfresh : observed (Fin.last (n + 1)) input = none)
+    (hprepared : ∃ start, observed (Fin.last n).castSucc start = some input) :
+    preparationCount observed + 1 ≤ preparationCount (record observed (Fin.last (n + 1), input) answer) := by
+  have hnot : input ∉ productiveInputs observed := by simp only [mem_productiveInputs, hfresh, ne_eq, not_true_eq_false, false_and, not_false_eq_true]
+  have hmem : input ∈ productiveInputs (record observed (Fin.last (n + 1), input) answer) := by
+    rw [mem_productiveInputs]
+    constructor
+    · simp only [record, Function.update_self, ne_eq, reduceCtorEq, not_false_eq_true]
+    · obtain ⟨start, hs⟩ := hprepared
+      refine ⟨start, ?_⟩
+      rw [record_at_other observed (Fin.last (n + 1), input) ((Fin.last n).castSucc, start) answer]
+      · exact hs
+      · intro heq
+        have hv := congrArg (fun query => query.1.val) heq
+        simp only [Fin.val_castSucc, Fin.val_last] at hv
+        omega
+  have hsub := productiveInputs_mono (record_extends observed (Fin.last (n + 1), input) answer (Or.inl hfresh))
+  have hcard := Finset.card_le_card (Finset.insert_subset hmem hsub)
+  rw [Finset.card_insert_of_notMem hnot] at hcard
+  exact hcard
+
+theorem preparation_charge_le_three_halves {n : Nat} (observed : Fin (n + 2) → State → Option State) :
+    2 * (longCompleted observed + 2 * preparationCount observed) ≤ 3 * queryCount observed := by
+  have hd := longCompleted_le_prefix_queries observed
+  have hp := preparationCount_le_prefix observed
+  have hl := preparationCount_le_last observed
+  rw [queryCount_split_last]
+  omega
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainRowCharge.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainRowCharge.lean
new file mode 100644
index 000000000..49a6664c6
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainRowCharge.lean
@@ -0,0 +1,151 @@
+import SphincsSecurity.Proof.Chains.PartialChainTwoEdge
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+
+private theorem weighted_event_le_bound {Result : Type} (law : PMF Result) (weight : Result → ENNReal)
+    (event : Result → Prop) [DecidablePred event] (bound : ENNReal) (hbound : ∀ result, weight result ≤ bound) :
+    (∑' result, law result * (weight result * if event result then 1 else 0)) ≤ bound * Pr[event | law] := by
+  rw [probEvent_eq_tsum_ite, ← ENNReal.tsum_mul_left]
+  apply ENNReal.tsum_le_tsum
+  intro result
+  by_cases hevent : event result
+  · simpa only [hevent, if_true, mul_one, PMF.probOutput_eq_apply, mul_comm] using mul_le_mul' (hbound result) (le_refl (law result))
+  · simp only [hevent, if_false, mul_zero, le_refl]
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+
+omit [DecidableEq State] in
+theorem kernel_snoc {n : Nat} (before : Fin n → State → Option State) (last : State → Option State) :
+    kernel (Fin.snoc before last) = fun start => (kernel before start).bind (fun input => rowLaw (last input)) := by
+  induction n with
+  | zero => funext start; simp [kernel, Fin.snoc_zero]
+  | succ n ih =>
+      funext start
+      have hs : Fin.snoc before last = @Fin.cons (n + 1) (fun _ => State → Option State) (before 0) (Fin.snoc (Fin.tail before) last) := by
+        rw [Fin.cons_snoc_eq_snoc_cons, Fin.cons_self_tail]
+      rw [hs, kernel, Fin.cons_zero, Fin.tail_cons]
+      rw [ih]
+      simp only [kernel, PMF.bind_bind]
+
+theorem row_update_charge (prior : PMF State) (observed : State → Option State) (next : State → PMF State)
+    (input answer endpoint : State) :
+    prior.bind (fun start => (rowLaw (Function.update observed input (some answer) start)).bind next) endpoint ≤
+      prior.bind (fun start => (rowLaw (observed start)).bind next) endpoint + prior input := by
+  rw [PMF.bind_apply]
+  calc
+    _ ≤ ∑' start, prior start * (((rowLaw (observed start)).bind next) endpoint + if start = input then 1 else 0) := by
+      apply ENNReal.tsum_le_tsum
+      intro start
+      apply mul_le_mul' le_rfl
+      by_cases hs : start = input
+      · rw [if_pos hs]
+        exact (PMF.coe_le_one _ endpoint).trans (_root_.le_add_of_nonneg_left bot_le)
+      · simp only [Function.update_of_ne hs, if_neg hs, add_zero, le_refl]
+    _ = _ := by
+      simp only [mul_add, ENNReal.tsum_add, mul_ite, mul_one, mul_zero, tsum_ite_eq, PMF.bind_apply]
+
+theorem meanPreimages_last_update_le {n : Nat} (before : Fin n → State → Option State) (last : State → Option State)
+    (input answer endpoint : State) :
+    meanPreimages (Fin.snoc before (Function.update last input (some answer))) endpoint ≤
+      meanPreimages (Fin.snoc before last) endpoint + meanPreimages before input := by
+  have h := row_update_charge ((PMF.uniformOfFintype State).bind (kernel before)) last PMF.pure input answer endpoint
+  simp only [PMF.bind_pure] at h
+  have hscaled := mul_le_mul' (le_refl (Fintype.card State : ENNReal)) h
+  simpa only [meanPreimages_eq, kernel_snoc, PMF.bind_bind, mul_add] using hscaled
+
+theorem meanPreimages_penultimate_update_le {n : Nat} (before : Fin n → State → Option State)
+    (penultimate last : State → Option State) (input answer endpoint : State) :
+    meanPreimages (Fin.snoc (Fin.snoc before (Function.update penultimate input (some answer))) last) endpoint ≤
+      meanPreimages (Fin.snoc (Fin.snoc before penultimate) last) endpoint + meanPreimages before input := by
+  have h := row_update_charge ((PMF.uniformOfFintype State).bind (kernel before)) penultimate
+    (fun middle => rowLaw (last middle)) input answer endpoint
+  have hscaled := mul_le_mul' (le_refl (Fintype.card State : ENNReal)) h
+  simpa only [meanPreimages_eq, kernel_snoc, PMF.bind_bind, mul_add] using hscaled
+
+theorem meanPreimages_record_last_le {n : Nat} (observed : Fin (n + 1) → State → Option State)
+    (input answer endpoint : State) :
+    meanPreimages (record observed (Fin.last n, input) answer) endpoint ≤
+      meanPreimages observed endpoint + meanPreimages (Fin.init observed) input := by
+  have h := meanPreimages_last_update_le (Fin.init observed) (observed (Fin.last n)) input answer endpoint
+  rw [Fin.snoc_init_self] at h
+  have hrecord : record observed (Fin.last n, input) answer =
+      Fin.snoc (Fin.init observed) (Function.update (observed (Fin.last n)) input (some answer)) := by
+    conv_lhs => rw [← Fin.snoc_init_self observed]
+    simp only [record, Fin.snoc_last, Fin.update_snoc_last]
+  simpa only [hrecord] using h
+
+theorem meanPreimages_record_penultimate_le {n : Nat} (observed : Fin (n + 2) → State → Option State)
+    (input answer endpoint : State) :
+    meanPreimages (record observed ((Fin.last n).castSucc, input) answer) endpoint ≤
+      meanPreimages observed endpoint + meanPreimages (Fin.init (Fin.init observed)) input := by
+  have h := meanPreimages_penultimate_update_le (Fin.init (Fin.init observed)) ((Fin.init observed) (Fin.last n))
+    (observed (Fin.last (n + 1))) input answer endpoint
+  rw [Fin.snoc_init_self, Fin.snoc_init_self] at h
+  have hrecord : record observed ((Fin.last n).castSucc, input) answer =
+      Fin.snoc (Fin.snoc (Fin.init (Fin.init observed))
+        (Function.update ((Fin.init observed) (Fin.last n)) input (some answer))) (observed (Fin.last (n + 1))) := by
+    conv_lhs => rw [← Fin.snoc_init_self observed, ← Fin.snoc_init_self (Fin.init observed)]
+    simp only [record, Fin.snoc_castSucc, Fin.snoc_last, ← Fin.snoc_update, Fin.update_snoc_last]
+  simpa only [hrecord] using h
+
+theorem twoEdge_last_density_charge {n : Nat} (observed : Fin (n + 2) → State → Option State)
+    (input answer endpoint : State) (h : ¬TwoEdge observed endpoint) :
+    meanPreimages (record observed (Fin.last (n + 1), input) answer) endpoint ≤
+      (2 + contactCount observed endpoint + targetCount (Fin.init observed) input : Nat) := by
+  have hprefix := meanPreimages_le_suffixCount (Fin.init observed) input
+  rw [suffixCount_eq_targetCount] at hprefix
+  apply (meanPreimages_record_last_le observed input answer endpoint).trans
+  have hsum := _root_.add_le_add (meanPreimages_le_contactCount_of_no_twoEdge observed endpoint h) hprefix
+  convert hsum using 1
+  push_cast
+  ring
+
+theorem twoEdge_penultimate_density_charge {n : Nat} (observed : Fin (n + 2) → State → Option State)
+    (input answer endpoint : State) (h : ¬TwoEdge observed endpoint) :
+    meanPreimages (record observed ((Fin.last n).castSucc, input) answer) endpoint ≤
+      (2 + contactCount observed endpoint + targetCount (Fin.init (Fin.init observed)) input : Nat) := by
+  have hprefix := meanPreimages_le_suffixCount (Fin.init (Fin.init observed)) input
+  rw [suffixCount_eq_targetCount] at hprefix
+  apply (meanPreimages_record_penultimate_le observed input answer endpoint).trans
+  have hsum := _root_.add_le_add (meanPreimages_le_contactCount_of_no_twoEdge observed endpoint h) hprefix
+  convert hsum using 1
+  push_cast
+  ring
+
+theorem twoEdge_last_weighted_risk {n : Nat} (observed : Fin (n + 2) → State → Option State)
+    (input endpoint : State) (h : ¬TwoEdge observed endpoint) (hfresh : observed (Fin.last (n + 1)) input = none) :
+    (∑' answer, rowLaw (observed (Fin.last (n + 1)) input) answer *
+      (meanPreimages (record observed (Fin.last (n + 1), input) answer) endpoint *
+        if TwoEdge (record observed (Fin.last (n + 1), input) answer) endpoint then 1 else 0)) ≤
+      if ∃ start, observed (Fin.last n).castSucc start = some input then
+        (2 + contactCount observed endpoint + targetCount (Fin.init observed) input : Nat) / (Fintype.card State : ENNReal) else 0 := by
+  classical
+  apply (weighted_event_le_bound (rowLaw (observed (Fin.last (n + 1)) input))
+    (fun answer => meanPreimages (record observed (Fin.last (n + 1), input) answer) endpoint)
+    (fun answer => TwoEdge (record observed (Fin.last (n + 1), input) answer) endpoint)
+    (2 + contactCount observed endpoint + targetCount (Fin.init observed) input : Nat)
+    (fun answer => twoEdge_last_density_charge observed input answer endpoint h)).trans_eq
+  rw [twoEdge_last_probability observed input endpoint h hfresh]
+  split <;> simp only [mul_zero, div_eq_mul_inv, one_mul]
+
+theorem twoEdge_penultimate_weighted_risk {n : Nat} (observed : Fin (n + 2) → State → Option State)
+    (input endpoint : State) (h : ¬TwoEdge observed endpoint) (hfresh : observed (Fin.last n).castSucc input = none) :
+    (∑' answer, rowLaw (observed (Fin.last n).castSucc input) answer *
+      (meanPreimages (record observed ((Fin.last n).castSucc, input) answer) endpoint *
+        if TwoEdge (record observed ((Fin.last n).castSucc, input) answer) endpoint then 1 else 0)) ≤
+      (contactCount observed endpoint * (2 + contactCount observed endpoint + targetCount (Fin.init (Fin.init observed)) input) : Nat) /
+        (Fintype.card State : ENNReal) := by
+  classical
+  apply (weighted_event_le_bound (rowLaw (observed (Fin.last n).castSucc input))
+    (fun answer => meanPreimages (record observed ((Fin.last n).castSucc, input) answer) endpoint)
+    (fun answer => TwoEdge (record observed ((Fin.last n).castSucc, input) answer) endpoint)
+    (2 + contactCount observed endpoint + targetCount (Fin.init (Fin.init observed)) input : Nat)
+    (fun answer => twoEdge_penultimate_density_charge observed input answer endpoint h)).trans_eq
+  rw [twoEdge_penultimate_probability observed input endpoint h hfresh]
+  simp only [Nat.cast_mul, div_eq_mul_inv]
+  ring
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainSuffix.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainSuffix.lean
new file mode 100644
index 000000000..035c388bb
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainSuffix.lean
@@ -0,0 +1,128 @@
+import SphincsSecurity.Proof.Chains.AdaptiveChainLikelihood
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec ENNReal
+set_option backward.isDefEq.respectTransparency false
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+
+def knownRun : {n : Nat} → (Fin n → State → Option State) → State → Option State
+  | 0, _, start => some start
+  | _ + 1, observed, start => (observed 0 start).bind (knownRun (Fin.tail observed))
+
+noncomputable def knownCount {n : Nat} (observed : Fin n → State → Option State) (endpoint : State) : Nat :=
+  ∑ start : State, if knownRun observed start = some endpoint then 1 else 0
+
+noncomputable def knownMass {n : Nat} (prior : PMF State) (observed : Fin n → State → Option State) (endpoint : State) : ENNReal :=
+  ∑' start, prior start * if knownRun observed start = some endpoint then 1 else 0
+
+noncomputable def properSuffixCount : {n : Nat} → (Fin n → State → Option State) → State → Nat
+  | 0, _, _ => 0
+  | _ + 1, observed, endpoint => knownCount (Fin.tail observed) endpoint + properSuffixCount (Fin.tail observed) endpoint
+
+omit [Nonempty State] in
+theorem knownCount_empty (observed : Fin 0 → State → Option State) (endpoint : State) : knownCount observed endpoint = 1 := by
+  simp [knownCount, knownRun]
+
+omit [Nonempty State] in
+theorem knownMass_empty (prior : PMF State) (observed : Fin 0 → State → Option State) (endpoint : State) :
+    knownMass prior observed endpoint = prior endpoint := by
+  simp [knownMass, knownRun]
+
+omit [Fintype State] [Nonempty State] in
+theorem knownMass_pure {n : Nat} (value : State) (observed : Fin n → State → Option State) (endpoint : State) :
+    knownMass (PMF.pure value) observed endpoint = if knownRun observed value = some endpoint then 1 else 0 := by
+  simpa only [knownMass, PMF.probOutput_eq_apply, PMF.monad_pure_eq_pure] using
+    (tsum_probOutput_pure_mul (m := PMF) value (fun start => if knownRun observed start = some endpoint then 1 else 0))
+
+theorem knownMass_uniform {n : Nat} (observed : Fin n → State → Option State) (endpoint : State) :
+    knownMass (PMF.uniformOfFintype State) observed endpoint =
+      (knownCount observed endpoint : ENNReal) / Fintype.card State := by
+  rw [knownMass, tsum_fintype, knownCount, Nat.cast_sum]
+  simp only [PMF.uniformOfFintype_apply, Nat.cast_ite, Nat.cast_one, Nat.cast_zero, div_eq_mul_inv,
+    Finset.mul_sum, mul_comm]
+
+theorem advance_knownMass_le {n : Nat} (prior : PMF State) (observed : Fin (n + 1) → State → Option State) (endpoint : State) :
+    knownMass (prior.bind (fun input => rowLaw (observed 0 input))) (Fin.tail observed) endpoint ≤
+      knownMass prior observed endpoint + (knownCount (Fin.tail observed) endpoint : ENNReal) / Fintype.card State := by
+  rw [knownMass, expectation_bind]
+  calc
+    _ ≤ ∑' input, prior input *
+        ((if knownRun observed input = some endpoint then 1 else 0) +
+          (knownCount (Fin.tail observed) endpoint : ENNReal) / Fintype.card State) := by
+      apply ENNReal.tsum_le_tsum
+      intro input
+      apply mul_le_mul' le_rfl
+      change knownMass (rowLaw (observed 0 input)) (Fin.tail observed) endpoint ≤ _
+      cases hrow : observed 0 input with
+      | none => simp only [rowLaw, knownMass_uniform, knownRun, hrow, Option.bind_none, reduceCtorEq, if_false, zero_add, le_refl]
+      | some value =>
+          simp only [rowLaw, knownMass_pure, knownRun, hrow, Option.bind_some]
+          exact _root_.le_add_of_nonneg_right bot_le
+    _ = _ := by
+      simp only [mul_add, ENNReal.tsum_add, ENNReal.tsum_mul_right, PMF.tsum_coe, one_mul, knownMass]
+
+theorem kernel_le_knownMass {n : Nat} (prior : PMF State) (observed : Fin n → State → Option State) (endpoint : State) :
+    prior.bind (kernel observed) endpoint ≤
+      knownMass prior observed endpoint + (properSuffixCount observed endpoint : ENNReal) / Fintype.card State := by
+  induction n generalizing prior with
+  | zero => simp [kernel, knownMass_empty, properSuffixCount]
+  | succ n ih =>
+      have h := ih (prior.bind (fun input => rowLaw (observed 0 input))) (Fin.tail observed)
+      have hstep := advance_knownMass_le prior observed endpoint
+      calc
+        _ ≤ knownMass (prior.bind (fun input => rowLaw (observed 0 input))) (Fin.tail observed) endpoint +
+            (properSuffixCount (Fin.tail observed) endpoint : ENNReal) / Fintype.card State := by
+          simpa only [kernel, PMF.bind_bind] using h
+        _ ≤ (knownMass prior observed endpoint + (knownCount (Fin.tail observed) endpoint : ENNReal) / Fintype.card State) +
+            (properSuffixCount (Fin.tail observed) endpoint : ENNReal) / Fintype.card State := _root_.add_le_add hstep le_rfl
+        _ = _ := by rw [properSuffixCount, Nat.cast_add, ENNReal.add_div, add_assoc]
+
+theorem meanPreimages_le_suffixCount {n : Nat} (observed : Fin n → State → Option State) (endpoint : State) :
+    meanPreimages observed endpoint ≤ (knownCount observed endpoint + properSuffixCount observed endpoint : Nat) := by
+  rw [meanPreimages_eq]
+  have h := mul_le_mul' (le_refl (Fintype.card State : ENNReal)) (kernel_le_knownMass (PMF.uniformOfFintype State) observed endpoint)
+  have hcard : (Fintype.card State : ENNReal) ≠ 0 := by exact_mod_cast Fintype.card_ne_zero
+  simpa only [knownMass_uniform, Nat.cast_add, div_eq_mul_inv, mul_add, mul_left_comm (Fintype.card State : ENNReal),
+    ENNReal.mul_inv_cancel hcard (by finiteness), mul_one] using h
+
+def Contact {n : Nat} (observed : Fin n → State → Option State) (endpoint : State) : Prop :=
+  ∃ step : Fin n, step.val + 1 = n ∧ ∃ input, observed step input = some endpoint
+
+omit [Fintype State] [DecidableEq State] [Nonempty State] in
+theorem contact_tail {n : Nat} (observed : Fin (n + 1) → State → Option State) (endpoint : State)
+    (h : Contact (Fin.tail observed) endpoint) : Contact observed endpoint := by
+  obtain ⟨step, hstep, input, hinput⟩ := h
+  exact ⟨step.succ, by simpa only [Fin.val_succ] using congrArg Nat.succ hstep, input, hinput⟩
+
+omit [Fintype State] [DecidableEq State] [Nonempty State] in
+theorem knownRun_contact {n : Nat} (observed : Fin (n + 1) → State → Option State) (start endpoint : State)
+    (h : knownRun observed start = some endpoint) : Contact observed endpoint := by
+  induction n generalizing start with
+  | zero =>
+      have hrow : observed 0 start = some endpoint := by
+        cases hstart : observed 0 start <;> simpa only [knownRun, hstart, Option.bind_none, Option.bind_some] using h
+      exact ⟨0, rfl, start, hrow⟩
+  | succ n ih =>
+      rw [knownRun, Option.bind_eq_some_iff] at h
+      obtain ⟨value, _, hvalue⟩ := h
+      exact contact_tail observed endpoint (ih (Fin.tail observed) value hvalue)
+
+omit [Nonempty State] in
+theorem knownCount_eq_zero_of_no_contact {n : Nat} (observed : Fin (n + 1) → State → Option State) (endpoint : State)
+    (h : ¬Contact observed endpoint) : knownCount observed endpoint = 0 := by
+  unfold knownCount
+  apply Finset.sum_eq_zero
+  intro start _
+  exact if_neg (fun hrun => h (knownRun_contact observed start endpoint hrun))
+
+omit [Nonempty State] in
+theorem suffixCount_le_one_of_no_contact {n : Nat} (observed : Fin n → State → Option State) (endpoint : State)
+    (h : ¬Contact observed endpoint) : knownCount observed endpoint + properSuffixCount observed endpoint ≤ 1 := by
+  induction n with
+  | zero => simp only [knownCount_empty, properSuffixCount, Nat.add_zero, le_refl]
+  | succ n ih =>
+      rw [knownCount_eq_zero_of_no_contact observed endpoint h, properSuffixCount, Nat.zero_add]
+      exact ih (Fin.tail observed) (fun htail => h (contact_tail observed endpoint htail))
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainTwoEdge.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainTwoEdge.lean
new file mode 100644
index 000000000..2edf3e88e
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainTwoEdge.lean
@@ -0,0 +1,129 @@
+import SphincsSecurity.Proof.Chains.PartialChainContactCount
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {State : Type} [Fintype State] [DecidableEq State]
+
+def TwoEdge {n : Nat} (observed : Fin (n + 2) → State → Option State) (endpoint : State) : Prop :=
+  ∃ start middle, observed (Fin.last n).castSucc start = some middle ∧ observed (Fin.last (n + 1)) middle = some endpoint
+
+omit [Fintype State] [DecidableEq State] in
+theorem twoEdge_mono {n : Nat} {before after : Fin (n + 2) → State → Option State} (hextends : Extends before after)
+    (endpoint : State) (h : TwoEdge before endpoint) : TwoEdge after endpoint := by
+  obtain ⟨start, middle, hfirst, hlast⟩ := h
+  exact ⟨start, middle, hextends _ _ _ hfirst, hextends _ _ _ hlast⟩
+
+omit [Fintype State] [DecidableEq State] in
+theorem twoEdge_tail {n : Nat} (observed : Fin (n + 3) → State → Option State) (endpoint : State)
+    (h : TwoEdge (Fin.tail observed) endpoint) : TwoEdge observed endpoint := by
+  obtain ⟨start, middle, hfirst, hlast⟩ := h
+  have hindex : (Fin.last n).castSucc.succ = (Fin.last (n + 1)).castSucc := by apply Fin.ext; rfl
+  exact ⟨start, middle, by simpa only [Fin.tail, hindex] using hfirst, by simpa only [Fin.tail, Fin.succ_last] using hlast⟩
+
+omit [Fintype State] [DecidableEq State] in
+theorem knownRun_twoEdge {n : Nat} (observed : Fin (n + 2) → State → Option State) (start endpoint : State)
+    (h : knownRun observed start = some endpoint) : TwoEdge observed endpoint := by
+  induction n generalizing start with
+  | zero =>
+      rw [knownRun, Option.bind_eq_some_iff] at h
+      obtain ⟨middle, hfirst, hlast⟩ := h
+      change (observed 1 middle).bind (fun value => some value) = some endpoint at hlast
+      have hrow : observed 1 middle = some endpoint := by
+        cases hrow : observed 1 middle <;> simpa only [hrow, Option.bind_none, Option.bind_some] using hlast
+      exact ⟨start, middle, hfirst, hrow⟩
+  | succ n ih =>
+      rw [knownRun, Option.bind_eq_some_iff] at h
+      obtain ⟨middle, _, htail⟩ := h
+      exact twoEdge_tail observed endpoint (ih (Fin.tail observed) middle htail)
+
+theorem knownCount_eq_zero_of_no_twoEdge {n : Nat} (observed : Fin (n + 2) → State → Option State) (endpoint : State)
+    (h : ¬TwoEdge observed endpoint) : knownCount observed endpoint = 0 := by
+  unfold knownCount
+  apply Finset.sum_eq_zero
+  intro start _
+  exact if_neg (fun hrun => h (knownRun_twoEdge observed start endpoint hrun))
+
+theorem targetCount_eq_contactCount_of_no_twoEdge {n : Nat} (observed : Fin (n + 2) → State → Option State) (endpoint : State)
+    (h : ¬TwoEdge observed endpoint) : targetCount observed endpoint = contactCount observed endpoint := by
+  induction n with
+  | zero =>
+      rw [targetCount, knownCount_eq_zero_of_no_twoEdge observed endpoint h, Nat.zero_add, targetCount, targetCount, Nat.add_zero,
+        ← contactCount_single, contactCount_tail]
+  | succ n ih =>
+      rw [targetCount, knownCount_eq_zero_of_no_twoEdge observed endpoint h, Nat.zero_add,
+        ih (Fin.tail observed) (fun htail => h (twoEdge_tail observed endpoint htail)), contactCount_tail]
+
+theorem meanPreimages_le_contactCount_of_no_twoEdge [Nonempty State] {n : Nat}
+    (observed : Fin (n + 2) → State → Option State) (endpoint : State) (h : ¬TwoEdge observed endpoint) :
+    meanPreimages observed endpoint ≤ (1 + contactCount observed endpoint : Nat) := by
+  have hbound := meanPreimages_le_suffixCount observed endpoint
+  rwa [suffixCount_eq_targetCount, targetCount_eq_contactCount_of_no_twoEdge observed endpoint h] at hbound
+
+omit [Fintype State] in
+theorem twoEdge_record_earlier {n : Nat} (observed : Fin (n + 2) → State → Option State) (query : Fin (n + 2) × State)
+    (answer endpoint : State) (hfirst : (Fin.last n).castSucc ≠ query.1) (hlast : Fin.last (n + 1) ≠ query.1) :
+    TwoEdge (record observed query answer) endpoint ↔ TwoEdge observed endpoint := by
+  simp only [TwoEdge, record, Function.update_of_ne hfirst, Function.update_of_ne hlast]
+
+omit [Fintype State] in
+theorem twoEdge_record_last {n : Nat} (observed : Fin (n + 2) → State → Option State) (input answer endpoint : State)
+    (h : ¬TwoEdge observed endpoint) :
+    TwoEdge (record observed (Fin.last (n + 1), input) answer) endpoint ↔
+      answer = endpoint ∧ ∃ start, observed (Fin.last n).castSucc start = some input := by
+  have hindex : (Fin.last n).castSucc ≠ Fin.last (n + 1) := by intro hh; have hv := congrArg Fin.val hh; simp only [Fin.val_castSucc, Fin.val_last] at hv; omega
+  constructor
+  · rintro ⟨start, middle, hfirst, hlast⟩
+    have hfirst' : observed (Fin.last n).castSucc start = some middle := by
+      simpa only [record, Function.update_of_ne hindex] using hfirst
+    by_cases hm : middle = input
+    · subst middle
+      exact ⟨by simpa only [record, Function.update_self, Option.some.injEq] using hlast, start, hfirst'⟩
+    · exact False.elim (h ⟨start, middle, hfirst', by simpa only [record, Function.update_self, Function.update_of_ne hm] using hlast⟩)
+  · rintro ⟨rfl, start, hfirst⟩
+    exact ⟨start, input, by simpa only [record, Function.update_of_ne hindex] using hfirst,
+      by simp only [record, Function.update_self]⟩
+
+omit [Fintype State] in
+theorem twoEdge_record_penultimate {n : Nat} (observed : Fin (n + 2) → State → Option State) (input answer endpoint : State)
+    (h : ¬TwoEdge observed endpoint) :
+    TwoEdge (record observed ((Fin.last n).castSucc, input) answer) endpoint ↔ observed (Fin.last (n + 1)) answer = some endpoint := by
+  have hindex : Fin.last (n + 1) ≠ (Fin.last n).castSucc := by intro hh; have hv := congrArg Fin.val hh; simp only [Fin.val_castSucc, Fin.val_last] at hv; omega
+  constructor
+  · rintro ⟨start, middle, hfirst, hlast⟩
+    have hlast' : observed (Fin.last (n + 1)) middle = some endpoint := by
+      simpa only [record, Function.update_of_ne hindex] using hlast
+    by_cases hs : start = input
+    · subst start
+      have hm : answer = middle := by simpa only [record, Function.update_self, Option.some.injEq] using hfirst
+      simpa only [hm] using hlast'
+    · exact False.elim (h ⟨start, middle, by simpa only [record, Function.update_self, Function.update_of_ne hs] using hfirst, hlast'⟩)
+  · intro hlast
+    exact ⟨input, answer, by simp only [record, Function.update_self], by simpa only [record, Function.update_of_ne hindex] using hlast⟩
+
+theorem twoEdge_last_probability [Nonempty State] {n : Nat}
+    (observed : Fin (n + 2) → State → Option State) (input endpoint : State)
+    (h : ¬TwoEdge observed endpoint) (hfresh : observed (Fin.last (n + 1)) input = none) :
+    Pr[fun answer => TwoEdge (record observed (Fin.last (n + 1), input) answer) endpoint |
+      rowLaw (observed (Fin.last (n + 1)) input)] =
+        if ∃ start, observed (Fin.last n).castSucc start = some input then 1 / (Fintype.card State : ENNReal) else 0 := by
+  classical
+  simp only [hfresh, rowLaw, probEvent_eq_tsum_ite, PMF.probOutput_eq_apply,
+    twoEdge_record_last observed input _ endpoint h]
+  by_cases hp : ∃ start, observed (Fin.last n).castSucc start = some input
+  · simp only [hp, and_true, if_true, tsum_ite_eq, PMF.uniformOfFintype_apply, one_div]
+  · simp only [hp, and_false, if_false, tsum_zero]
+
+theorem twoEdge_penultimate_probability [Nonempty State] {n : Nat}
+    (observed : Fin (n + 2) → State → Option State) (input endpoint : State)
+    (h : ¬TwoEdge observed endpoint) (hfresh : observed (Fin.last n).castSucc input = none) :
+    Pr[fun answer => TwoEdge (record observed ((Fin.last n).castSucc, input) answer) endpoint |
+      rowLaw (observed (Fin.last n).castSucc input)] = (contactCount observed endpoint : ENNReal) / Fintype.card State := by
+  classical
+  simp only [hfresh, rowLaw, probEvent_eq_tsum_ite, PMF.probOutput_eq_apply,
+    twoEdge_record_penultimate observed input _ endpoint h, PMF.uniformOfFintype_apply, tsum_fintype,
+    contactCount_succ, Nat.cast_sum, Nat.cast_ite, Nat.cast_one, Nat.cast_zero, div_eq_mul_inv,
+    Finset.sum_mul, ite_mul, one_mul, zero_mul]
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainTwoEdgeCharge.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainTwoEdgeCharge.lean
new file mode 100644
index 000000000..478bdd337
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainTwoEdgeCharge.lean
@@ -0,0 +1,103 @@
+import SphincsSecurity.Proof.Chains.PartialChainPreparation
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {State : Type} [Fintype State] [DecidableEq State]
+
+theorem contactCount_mono {n : Nat} {before after : Fin n → State → Option State}
+    (h : Extends before after) (endpoint : State) : contactCount before endpoint ≤ contactCount after endpoint := by
+  unfold contactCount
+  apply Finset.sum_le_sum
+  intro query _
+  by_cases hk : query.1.val + 1 = n ∧ before query.1 query.2 = some endpoint
+  · have hk' : query.1.val + 1 = n ∧ after query.1 query.2 = some endpoint := ⟨hk.1, h _ _ _ hk.2⟩
+    simp only [if_pos hk, if_pos hk', le_refl]
+  · simp only [if_neg hk, Nat.zero_le]
+
+noncomputable def twoEdgeCharge {n : Nat} (spent : Nat) (observed : Fin (n + 2) → State → Option State) (endpoint : State) : Nat :=
+  longCompleted observed + 2 * preparationCount observed +
+    spent * (contactCount observed endpoint * (contactCount observed endpoint + 2)) +
+    contactCount observed endpoint * longCompleted (Fin.init observed)
+
+theorem twoEdgeCharge_empty {n : Nat} (endpoint : State) :
+    twoEdgeCharge 0 (n := n) (fun _ _ => none) endpoint = 0 := by
+  simp only [twoEdgeCharge, longCompleted_empty, preparationCount_empty, contactCount_empty,
+    Nat.mul_zero, Nat.zero_mul, Nat.add_zero]
+
+theorem twoEdgeCharge_mono {n : Nat} {before after : Fin (n + 2) → State → Option State}
+    {spent next : Nat} (hs : spent ≤ next) (h : Extends before after) (endpoint : State) :
+    twoEdgeCharge spent before endpoint ≤ twoEdgeCharge next after endpoint := by
+  unfold twoEdgeCharge
+  exact Nat.add_le_add
+    (Nat.add_le_add (Nat.add_le_add (longCompleted_mono h) (Nat.mul_le_mul_left 2 (preparationCount_mono h)))
+      (Nat.mul_le_mul hs (Nat.mul_le_mul (contactCount_mono h endpoint) (Nat.add_le_add_right (contactCount_mono h endpoint) 2))))
+    (Nat.mul_le_mul (contactCount_mono h endpoint) (longCompleted_mono h.init))
+
+private theorem charge_increment (d p r k d' p' r' k' spent dd dp dr : Nat)
+    (hd : d + dd ≤ d') (hp : p + dp ≤ p') (hr : r + dr ≤ r') (hk : k ≤ k') :
+    (d + 2 * p + spent * (k * (k + 2)) + k * r) + dd + 2 * dp + k * (k + 2) + k * dr ≤
+      d' + 2 * p' + (spent + 1) * (k' * (k' + 2)) + k' * r' := by
+  have hpoly := Nat.mul_le_mul (Nat.le_refl (spent + 1)) (Nat.mul_le_mul hk (Nat.add_le_add_right hk 2))
+  have hprod := Nat.mul_le_mul hk hr
+  have hsum := Nat.add_le_add (Nat.add_le_add (Nat.add_le_add hd (Nat.mul_le_mul_left 2 hp)) hpoly) hprod
+  convert hsum using 1
+  ring
+
+theorem twoEdgeCharge_record_last {n : Nat} (spent : Nat) (observed : Fin (n + 2) → State → Option State)
+    (input answer endpoint : State) (hfresh : observed (Fin.last (n + 1)) input = none)
+    (hprepared : ∃ start, observed (Fin.last n).castSucc start = some input) :
+    twoEdgeCharge spent observed endpoint + (2 + contactCount observed endpoint + targetCount (Fin.init observed) input) ≤
+      twoEdgeCharge (spent + 1) (record observed (Fin.last (n + 1), input) answer) endpoint := by
+  have hext := record_extends observed (Fin.last (n + 1), input) answer (Or.inl hfresh)
+  have h := charge_increment _ _ _ _ _ _ _ _ spent (targetCount (Fin.init observed) input) 1 0
+    (le_of_eq (longCompleted_record_last observed input answer hfresh).symm)
+    (preparationCount_last_fresh observed input answer hfresh hprepared)
+    (by simpa only [Nat.add_zero] using longCompleted_mono hext.init) (contactCount_mono hext endpoint)
+  change twoEdgeCharge spent observed endpoint + _ + _ + _ + _ ≤ twoEdgeCharge (spent + 1) _ endpoint at h
+  have hk : contactCount observed endpoint ≤ contactCount observed endpoint * (contactCount observed endpoint + 2) := by nlinarith
+  omega
+
+theorem twoEdgeCharge_record_penultimate {n : Nat} (spent : Nat) (observed : Fin (n + 2) → State → Option State)
+    (input answer endpoint : State) (hfresh : observed (Fin.last n).castSucc input = none) :
+    twoEdgeCharge spent observed endpoint +
+      contactCount observed endpoint * (2 + contactCount observed endpoint + targetCount (Fin.init (Fin.init observed)) input) ≤
+      twoEdgeCharge (spent + 1) (record observed ((Fin.last n).castSucc, input) answer) endpoint := by
+  have hext := record_extends observed ((Fin.last n).castSucc, input) answer (Or.inl hfresh)
+  have h := charge_increment _ _ _ _ _ _ _ _ spent 0 0 (targetCount (Fin.init (Fin.init observed)) input)
+    (by simpa only [Nat.add_zero] using longCompleted_mono hext)
+    (by simpa only [Nat.add_zero] using preparationCount_mono hext)
+    (le_of_eq (longCompleted_prefix_record_penultimate observed input answer hfresh).symm) (contactCount_mono hext endpoint)
+  change twoEdgeCharge spent observed endpoint + _ + _ + _ + _ ≤ twoEdgeCharge (spent + 1) _ endpoint at h
+  convert h using 1
+  ring
+
+theorem contact_correction_identity (k : Nat) : k * (k + 2) + k = contactFactorial k + 4 * k := by
+  cases k with
+  | zero => rfl
+  | succ k => simp only [contactFactorial, Nat.add_sub_cancel]; ring
+
+theorem twoEdgeCharge_le {n : Nat} (spent budget : Nat) (observed : Fin (n + 2) → State → Option State)
+    (endpoint : State) (hs : spent ≤ budget) (hq : queryCount observed ≤ budget) :
+    twoEdgeCharge spent observed endpoint ≤ longCompleted observed + 2 * preparationCount observed +
+      budget * (contactFactorial (contactCount observed endpoint) + 4 * contactCount observed endpoint) := by
+  have hr := longCompleted_le_queryCount (Fin.init observed)
+  have hsplit := queryCount_split_last observed
+  have hrq : longCompleted (Fin.init observed) ≤ budget := by omega
+  have hprod := Nat.mul_le_mul_left (contactCount observed endpoint) hrq
+  have hspent := Nat.mul_le_mul_right (contactCount observed endpoint * (contactCount observed endpoint + 2)) hs
+  have hsum := Nat.add_le_add hspent hprod
+  rw [Nat.mul_comm (contactCount observed endpoint) budget, ← Nat.mul_add, contact_correction_identity] at hsum
+  unfold twoEdgeCharge
+  omega
+
+theorem twoEdgeCharge_twice_le {n : Nat} (spent budget : Nat) (observed : Fin (n + 2) → State → Option State)
+    (endpoint : State) (hs : spent ≤ budget) (hq : queryCount observed ≤ budget) :
+    2 * twoEdgeCharge spent observed endpoint ≤ 3 * queryCount observed +
+      2 * budget * (contactFactorial (contactCount observed endpoint) + 4 * contactCount observed endpoint) := by
+  have h := twoEdgeCharge_le spent budget observed endpoint hs hq
+  have hbase := preparation_charge_le_three_halves observed
+  nlinarith
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainTwoEdgeCompensation.lean b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainTwoEdgeCompensation.lean
new file mode 100644
index 000000000..d596420e9
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Chains/PartialChainTwoEdgeCompensation.lean
@@ -0,0 +1,110 @@
+import SphincsSecurity.Proof.Chains.PartialChainTwoEdgeCharge
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+
+variable {State : Type} [Fintype State] [DecidableEq State] [Nonempty State]
+
+noncomputable def twoEdgeWeight {n : Nat} (observed : Fin (n + 2) → State → Option State) (endpoint : State) : ENNReal :=
+  meanPreimages observed endpoint * if TwoEdge observed endpoint then 1 else 0
+
+theorem twoEdgeWeight_empty {n : Nat} (endpoint : State) :
+    twoEdgeWeight (n := n) (fun _ _ => none) endpoint = 0 := by
+  simp [twoEdgeWeight, TwoEdge]
+
+omit [DecidableEq State] [Nonempty State] in
+private theorem expected_charge_cover (law : PMF State) (before increment : Nat) (after : State → Nat)
+    (weight : State → ENNReal)
+    (hrisk : (∑' answer, law answer * weight answer) ≤ (increment : ENNReal) / Fintype.card State)
+    (hcharge : ∀ answer, before + increment ≤ after answer) :
+    (before : ENNReal) / Fintype.card State + (∑' answer, law answer * weight answer) ≤
+      ∑' answer, law answer * ((after answer : ENNReal) / Fintype.card State) := by
+  calc
+    _ ≤ (before : ENNReal) / Fintype.card State + (increment : ENNReal) / Fintype.card State := _root_.add_le_add le_rfl hrisk
+    _ = ((before + increment : Nat) : ENNReal) / Fintype.card State := by simp only [Nat.cast_add, div_eq_mul_inv, add_mul]
+    _ = ∑' answer, law answer * (((before + increment : Nat) : ENNReal) / Fintype.card State) := (expectation_const _ _).symm
+    _ ≤ _ := ENNReal.tsum_le_tsum fun answer => mul_le_mul' le_rfl (by gcongr; exact_mod_cast hcharge answer)
+
+theorem twoEdgeCharge_observe_mono {n : Nat} (spent : Nat) (observed : Fin (n + 2) → State → Option State)
+    (query : Fin (n + 2) × State) (endpoint : State) :
+    (twoEdgeCharge spent observed endpoint : ENNReal) / Fintype.card State ≤
+      ∑' answer, rowLaw (observed query.1 query.2) answer *
+        ((twoEdgeCharge (spent + 1) (record observed query answer) endpoint : ENNReal) / Fintype.card State) := by
+  cases hrow : observed query.1 query.2 with
+  | some answer =>
+      simp only [rowLaw, expectation_pure, record_of_known observed query answer hrow]
+      gcongr
+      exact twoEdgeCharge_mono (Nat.le_succ spent) (fun _ _ _ h => h) endpoint
+  | none =>
+      rw [← expectation_const (rowLaw (none : Option State)) ((twoEdgeCharge spent observed endpoint : ENNReal) / Fintype.card State)]
+      apply ENNReal.tsum_le_tsum
+      intro answer
+      apply mul_le_mul' le_rfl
+      gcongr
+      exact twoEdgeCharge_mono (Nat.le_succ spent) (record_extends observed query answer (Or.inl hrow)) endpoint
+
+theorem twoEdgeWeight_observe_of_bad {n : Nat} (observed : Fin (n + 2) → State → Option State)
+    (query : Fin (n + 2) × State) (endpoint : State) (hbad : TwoEdge observed endpoint) :
+    (∑' answer, rowLaw (observed query.1 query.2) answer * twoEdgeWeight (record observed query answer) endpoint) =
+      twoEdgeWeight observed endpoint := by
+  cases hrow : observed query.1 query.2 with
+  | some answer => simp only [rowLaw, expectation_pure, record_of_known observed query answer hrow]
+  | none =>
+      have hafter (answer : State) : TwoEdge (record observed query answer) endpoint :=
+        twoEdge_mono (record_extends observed query answer (Or.inl hrow)) endpoint hbad
+      simp only [twoEdgeWeight, if_pos hbad, if_pos (hafter _), mul_one]
+      simpa only [hrow] using meanPreimages_observe observed query endpoint
+
+theorem twoEdge_first_compensation {n : Nat} (spent : Nat) (observed : Fin (n + 2) → State → Option State)
+    (query : Fin (n + 2) × State) (endpoint : State) (hbad : ¬TwoEdge observed endpoint)
+    (hfresh : observed query.1 query.2 = none) :
+    (twoEdgeCharge spent observed endpoint : ENNReal) / Fintype.card State +
+      (∑' answer, rowLaw (observed query.1 query.2) answer * twoEdgeWeight (record observed query answer) endpoint) ≤
+      ∑' answer, rowLaw (observed query.1 query.2) answer *
+        ((twoEdgeCharge (spent + 1) (record observed query answer) endpoint : ENNReal) / Fintype.card State) := by
+  rcases query with ⟨step, input⟩
+  by_cases hlast : step = Fin.last (n + 1)
+  · subst step
+    by_cases hprepared : ∃ start, observed (Fin.last n).castSucc start = some input
+    · apply expected_charge_cover _ _ (2 + contactCount observed endpoint + targetCount (Fin.init observed) input)
+      · simpa only [twoEdgeWeight, if_pos hprepared] using twoEdge_last_weighted_risk observed input endpoint hbad hfresh
+      · intro answer
+        exact twoEdgeCharge_record_last spent observed input answer endpoint hfresh hprepared
+    · apply expected_charge_cover _ _ 0
+      · simpa only [twoEdgeWeight, if_neg hprepared, Nat.cast_zero, div_eq_mul_inv, zero_mul] using twoEdge_last_weighted_risk observed input endpoint hbad hfresh
+      · intro answer
+        simpa only [Nat.add_zero] using twoEdgeCharge_mono (Nat.le_succ spent)
+          (record_extends observed (Fin.last (n + 1), input) answer (Or.inl hfresh)) endpoint
+  · by_cases hpen : step = (Fin.last n).castSucc
+    · subst step
+      apply expected_charge_cover _ _ (contactCount observed endpoint * (2 + contactCount observed endpoint + targetCount (Fin.init (Fin.init observed)) input))
+      · exact twoEdge_penultimate_weighted_risk observed input endpoint hbad hfresh
+      · intro answer
+        exact twoEdgeCharge_record_penultimate spent observed input answer endpoint hfresh
+    · have hafter (answer : State) : ¬TwoEdge (record observed (step, input) answer) endpoint := by
+        rw [twoEdge_record_earlier observed (step, input) answer endpoint (Ne.symm hpen) (Ne.symm hlast)]
+        exact hbad
+      simp only [twoEdgeWeight, if_neg (hafter _), mul_zero, tsum_zero, add_zero]
+      exact twoEdgeCharge_observe_mono spent observed (step, input) endpoint
+
+theorem twoEdge_observe_compensation {n : Nat} (spent : Nat) (observed : Fin (n + 2) → State → Option State)
+    (query : Fin (n + 2) × State) (endpoint : State) :
+    (twoEdgeCharge spent observed endpoint : ENNReal) / Fintype.card State +
+      (∑' answer, rowLaw (observed query.1 query.2) answer * twoEdgeWeight (record observed query answer) endpoint) ≤
+      twoEdgeWeight observed endpoint + ∑' answer, rowLaw (observed query.1 query.2) answer *
+        ((twoEdgeCharge (spent + 1) (record observed query answer) endpoint : ENNReal) / Fintype.card State) := by
+  by_cases hbad : TwoEdge observed endpoint
+  · rw [twoEdgeWeight_observe_of_bad observed query endpoint hbad, add_comm]
+    exact _root_.add_le_add le_rfl (twoEdgeCharge_observe_mono spent observed query endpoint)
+  · have hzero : twoEdgeWeight observed endpoint = 0 := by simp only [twoEdgeWeight, if_neg hbad, mul_zero]
+    rw [hzero, zero_add]
+    cases hrow : observed query.1 query.2 with
+    | none => simpa only [hrow] using twoEdge_first_compensation spent observed query endpoint hbad hrow
+    | some answer =>
+        simp only [rowLaw, expectation_pure, record_of_known observed query answer hrow, hzero, add_zero]
+        gcongr
+        exact twoEdgeCharge_mono (Nat.le_succ spent) (fun _ _ _ h => h) endpoint
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessAuxiliaryProgram.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessAuxiliaryProgram.lean
new file mode 100644
index 000000000..86009fe4b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessAuxiliaryProgram.lean
@@ -0,0 +1,149 @@
+import SphincsSecurity.Proof.Forced.FtsGuessNearSource
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+  publicDigestLoop canonicalGraphRoot canonicalGraphInput
+
+abbrev SeedSpec (inputs : Finset HashInput) := unifSpec + (inputs →ₒ HashOutput)
+
+noncomputable def seedAnswers (inputs : Finset HashInput) (seed : inputs → HashOutput) : QueryImpl (SeedSpec inputs) ProbComp
+  | .inl input => liftM (unifSpec.query input)
+  | .inr input => pure (seed input)
+
+noncomputable def residualProgram {Row : Type} (inputs : Finset HashInput) (embed : Row → inputs)
+    (rows : Row → HashOutput) (input : HashInput) : OracleComp (SeedSpec inputs) HashOutput :=
+  if hi : input ∈ inputs then
+    if hr : (⟨input, hi⟩ : inputs) ∈ Set.range embed then pure (rows (Classical.choose hr))
+    else liftM ((SeedSpec inputs).query (.inr ⟨input, hi⟩))
+  else pure 0
+
+theorem residualProgram_fixed {Row : Type} (inputs : Finset HashInput) (embed : Row → inputs)
+    (hinj : Function.Injective embed) (rows : Row → HashOutput) (seed : inputs → HashOutput) (input : HashInput) :
+    simulateQ (seedAnswers inputs seed) (residualProgram inputs embed rows input) =
+      pure (finiteHashAnswer ∅ inputs (UniformTableSplit.overwrite embed hinj rows seed) input) := by
+  by_cases hi : input ∈ inputs
+  · rw [residualProgram, dif_pos hi, finiteHashAnswer_none _ _ _ _ hi (by simp)]
+    by_cases hr : (⟨input, hi⟩ : inputs) ∈ Set.range embed
+    · rw [dif_pos hr, simulateQ_pure]
+      have he := Classical.choose_spec hr
+      exact congrArg pure ((congrArg (UniformTableSplit.overwrite embed hinj rows seed) he).symm.trans
+        (UniformTableSplit.overwrite_embed embed hinj rows seed (Classical.choose hr))).symm
+    · rw [dif_neg hr, simulateQ_spec_query, UniformTableSplit.overwrite_outside _ _ _ _ _ hr]
+      rfl
+  · simp only [residualProgram, dif_neg hi, simulateQ_pure, finiteHashAnswer, QueryCache.empty_apply, Option.getD_none]
+
+noncomputable def publicRecordProgram {TargetIndex : Type} {targetSpec : OracleSpec TargetIndex}
+    (parameter : PublicParameter) (root : Digest) (outside : QueryImpl OracleWorld (OracleComp targetSpec))
+    (known : Labels) (words : OtsReferenceWords) (selections : ReferenceFamily) (message : Message) :
+    OracleComp targetSpec PublicSigningRecord := do
+  let selected ← simulateQ outside
+    (QueryPause.traced (signingBoundaryTrace parameter) (publicDigestLoop parameter root message digestAttemptLimit))
+  match selected.1 with
+  | none => pure ((none, none), selected.2)
+  | some (randomness, index, leaves) =>
+      let plan := publicSignPlan known words selections randomness index leaves
+      pure ((plan.1, some (selectedFewTimeView index leaves)), selected.2 * (FreeMonoid.of none) ^ plan.2)
+
+theorem fixed_traced {Result : Type} (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (computation : OracleComp OracleWorld Result) :
+    simulateQ (fixedHashWorld f) (QueryPause.traced (signingBoundaryTrace parameter) computation) =
+      fixedBoundaryRun parameter f computation := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => simp only [QueryPause.traced_pure, simulateQ_pure, fixedBoundaryRun_pure]
+  | query_bind input next ih =>
+      simp only [QueryPause.traced_query_bind, simulateQ_bind, simulateQ_spec_query, simulateQ_map,
+        ih, ResidualByteFrontend.fixedBoundaryRun_query_bind]
+
+theorem publicRecordProgram_fixed {TargetIndex : Type} {targetSpec : OracleSpec TargetIndex}
+    (parameter : PublicParameter) (root : Digest) (outside : QueryImpl OracleWorld (OracleComp targetSpec))
+    (known : Labels) (words : OtsReferenceWords) (selections : ReferenceFamily) (message : Message)
+    (runtime : QueryImpl targetSpec ProbComp) (f : QueryImpl HashSpec Id)
+    (houtside : ∀ input, simulateQ runtime (outside input) = fixedHashWorld f input) :
+    simulateQ runtime (publicRecordProgram parameter root outside known words selections message) =
+      publicSigningRecord parameter root f known words selections message := by
+  have hcompose : runtime.compose outside = fixedHashWorld f := funext houtside
+  rw [publicRecordProgram, simulateQ_bind, ← QueryImpl.simulateQ_compose, hcompose, fixed_traced, publicSigningRecord]
+  apply congrArg (fixedBoundaryRun parameter f (publicDigestLoop parameter root message digestAttemptLimit) >>= ·)
+  funext selected
+  cases selected.1 <;> rfl
+
+noncomputable def residualWorld (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (known : Labels) (rows : CanonicalEncodingRows) :
+    QueryImpl OracleWorld (OracleComp (SeedSpec inputs))
+  | .inl input => liftM ((SeedSpec inputs).query (.inl input))
+  | .inr input => residualProgram inputs (knownEncodingCell parameter inputs hencoding known) rows input
+
+theorem residualWorld_fixed (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (known : Labels) (rows : CanonicalEncodingRows)
+    (seed : inputs → HashOutput) (input : OracleWorld.Domain) :
+    simulateQ (seedAnswers inputs seed) (residualWorld parameter inputs hencoding known rows input) =
+      fixedHashWorld (finiteHashAnswer ∅ inputs (knownReferenceResidual parameter inputs hencoding known rows seed)) input := by
+  cases input with
+  | inl input => rfl
+  | inr input => exact residualProgram_fixed inputs _ (knownEncodingCell_injective parameter inputs hencoding known) rows seed input
+
+noncomputable def auxiliaryHashProgram (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+    (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+    (rows : CanonicalEncodingRows) (input : HashInput) : OracleComp (SeedSpec inputs) HashOutput :=
+  let residual := residualProgram inputs (canonicalEncodingCell parameter inputs hencoding labels) rows input
+  match FtsProbeSimulation.decodeProbe? parameter input with
+  | some _ => residual
+  | none => match decodePosition parameter input with
+    | none => residual
+    | some position =>
+        if input = canonicalGraphInput parameter otsSecret (fun _ _ _ => 0) position labels then pure (labels position)
+        else residual
+
+theorem auxiliaryHashProgram_fixed (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+    (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+    (rows : CanonicalEncodingRows) (seed : inputs → HashOutput) (input : HashInput) :
+    simulateQ (seedAnswers inputs seed) (auxiliaryHashProgram parameter otsSecret labels inputs hencoding rows input) =
+      pure (auxiliaryHash parameter otsSecret labels
+        (finiteHashAnswer ∅ inputs (canonicalReferenceResidual parameter inputs hencoding labels rows seed)) input) := by
+  have hr := residualProgram_fixed inputs (canonicalEncodingCell parameter inputs hencoding labels)
+    (canonicalEncodingCell_injective parameter inputs hencoding labels) rows seed input
+  simp only [canonicalReferenceResidual]
+  cases hp : FtsProbeSimulation.decodeProbe? parameter input with
+  | some probe => simpa only [auxiliaryHashProgram, auxiliaryHash, hp] using hr
+  | none =>
+      simp only [auxiliaryHashProgram, auxiliaryHash, hp, programmedHash]
+      cases hd : decodePosition parameter input with
+      | none => simpa only [Option.elim_none] using hr
+      | some position =>
+          simp only [Option.elim_some]
+          split <;> simp only [simulateQ_pure, hr]
+
+noncomputable def referenceProgram (parameter : PublicParameter) (root : Digest)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+    (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+    (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (dummy : OtsReferenceWords) :
+    QueryImpl Auxiliary (OracleComp (SeedSpec inputs))
+  | .inl (.inl input) => liftM ((SeedSpec inputs).query (.inl input))
+  | .inl (.inr input) => auxiliaryHashProgram parameter otsSecret labels inputs hencoding rows input
+  | .inr message => publicRecordProgram parameter root
+      (residualWorld parameter inputs hencoding (known otsSecret labels) rows)
+      (known otsSecret labels) (referenceFamilyWords selections dummy) selections message
+
+theorem referenceProgram_fixed (parameter : PublicParameter) (root : Digest)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+    (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+    (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (seed : inputs → HashOutput)
+    (dummy : OtsReferenceWords) (input : Auxiliary.Domain) :
+    simulateQ (seedAnswers inputs seed)
+      (referenceProgram parameter root otsSecret labels inputs hencoding selections rows dummy input) =
+        referenceAnswers parameter root otsSecret labels inputs hencoding ⟨selections, rows, seed⟩ dummy input := by
+  cases input with
+  | inl input =>
+      cases input with
+      | inl input => rfl
+      | inr input => exact auxiliaryHashProgram_fixed parameter otsSecret labels inputs hencoding rows seed input
+  | inr message =>
+      exact publicRecordProgram_fixed parameter root _ _ _ selections message (seedAnswers inputs seed) _
+        (residualWorld_fixed parameter inputs hencoding (known otsSecret labels) rows seed)
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessBudget.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessBudget.lean
new file mode 100644
index 000000000..64a9c0328
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessBudget.lean
@@ -0,0 +1,158 @@
+import SphincsSecurity.Proof.Forced.FtsGuessWork
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec OtsContactTrace
+open FtsGuessSigning (Coordinate)
+open SecretGuessObservation (State Environment fixedRun)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] instSampleableTypePublicParameter canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  frontierRoot maskOtsPrefixes frontierSigningRun boundaryEval
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def verdict (result : Completed) : Bool × SigningBoundaryTrace :=
+  (decide (SigningTranscript.Valid result.1.1.1.2 ∧ ¬SigningTranscript.Contains result.1.1.1.2 result.1.1.1.1) && result.2.1.1,
+    (FreeMonoid.of none) ^ 1212415 * (result.1.1.2 * result.2.1.2))
+
+theorem verdict_work (result : Completed) : (verdict result).2.hashCalls = 1212415 + completedWork result := by
+  simp only [verdict, SigningBoundaryTrace.hashCalls_mul, SigningBoundaryTrace.hashCalls_pow_none, completedWork]
+
+theorem referenceForgeryRest_verdict (key : SecretKey) (f : QueryImpl HashSpec Id) (labels : CanonicalGraphLabels)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (fun before => (completedReferenceContact key.parameter f (referenceFamilyWords selections dummy)
+      (canonicalGraphFrontier key.otsSecret labels (referenceFamilyWords selections dummy)) before).output) <$>
+      referenceForgeryRest key f labels selections dummy adversary =
+      referenceFamilyFrontierRest key f labels selections dummy adversary := by
+  have h := congrArg (Functor.map Prod.fst) (referenceForgeryRest_trace key f labels selections dummy adversary)
+  rw [Functor.map_map, fixedTrace_forget, CausalFrontierProgram.fixed_game,
+    ← causalFrontierGame_eq] at h
+  exact h
+
+theorem reference_completed_verdict (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary inputs) (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    verdict <$> simulateQ
+      (fixedAnswers (referenceAnswers key.parameter (canonicalGraphRoot labels) key.otsSecret labels inputs hencoding auxiliary dummy)
+        (FtsGuessSigning.secretTable key.ftsSecret))
+      (completedRun key.parameter (canonicalGraphRoot labels) labels adversary) =
+      referenceFamilyFrontierRest key
+        (programmedHash key.parameter key.otsSecret key.ftsSecret labels
+          (finiteHashAnswer ∅ inputs (canonicalReferenceResidual key.parameter inputs hencoding labels auxiliary.rows auxiliary.seed)))
+        labels auxiliary.selections dummy adversary := by
+  rw [fixed_reference_completedForgeryRest key inputs hencoding labels auxiliary hauxiliary dummy adversary, Functor.map_map,
+    ← referenceForgeryRest_verdict]
+  congr 1
+  funext before
+  simp only [verdict, completedAtRoot, completedReferenceContact, reference_root]
+
+private theorem probComp_nonzero {Result : Type} (computation : ProbComp Result) (result : Result)
+    (hr : result ∈ support computation) : 𝒟[computation] result ≠ 0 := by
+  simpa only [mem_support_iff, probOutput_def] using hr
+
+theorem referenceResidualGame_auxiliary_support (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (dummy : OtsReferenceWords) (adversary : Adversary)
+    (parameter : PublicParameter) (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (auxiliary : ReferenceAuxiliary inputs)
+    (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support) (labels : CanonicalGraphLabels)
+    (result : Bool × SigningBoundaryTrace)
+    (hr : 𝒟[referenceFamilyFrontierRest ⟨parameter, 0, otsSecret, ftsSecret⟩
+      (programmedHash parameter otsSecret ftsSecret labels
+        (finiteHashAnswer ∅ inputs (canonicalReferenceResidual parameter inputs (hencoding parameter) labels auxiliary.rows auxiliary.seed)))
+      labels auxiliary.selections dummy adversary] result ≠ 0) :
+    (auxiliary.selections, result) ∈ support (referenceResidualGame inputs hencoding dummy adversary) := by
+  rw [mem_support_iff]
+  change referenceResidualGame inputs hencoding dummy adversary (auxiliary.selections, result) ≠ 0
+  rw [referenceResidualGame_eq_auxiliary]
+  simp only [RetainedObservation.bind_nonzero]
+  refine ⟨parameter, probComp_nonzero sampleParameter parameter ?_, otsSecret, probComp_nonzero sampleOtsSecrets otsSecret ?_,
+    ftsSecret, probComp_nonzero sampleFtsSecrets ftsSecret ?_, auxiliary, ?_, labels, ?_, result, hr, ?_⟩
+  · unfold sampleParameter
+    exact @mem_support_uniformSample PublicParameter instSampleableTypePublicParameter parameter
+  · simp only [sampleOtsSecrets, support_uniformSample, Set.mem_univ]
+  · simp only [sampleFtsSecrets, support_uniformSample, Set.mem_univ]
+  · simpa only [SPMF.liftM_apply] using (PMF.mem_support_iff _ _).mp hauxiliary
+  · simpa only [SPMF.liftM_apply] using (PMF.mem_support_iff _ _).mp (PMF.mem_support_uniformOfFintype labels)
+  · simp
+
+noncomputable def originalAnswers (dummy : OtsReferenceWords) (adversary : Adversary) (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary (canonicalGraphGameInputs adversary)) : QueryImpl Auxiliary ProbComp :=
+  referenceAnswers parameter (canonicalGraphRoot labels) otsSecret labels (canonicalGraphGameInputs adversary)
+    (canonicalEncodingInputs_subset_gameInputs adversary parameter) auxiliary dummy
+
+theorem original_completedWork_le (dummy : OtsReferenceWords) (adversary : Adversary) (q : Nat)
+    (hbound : HasHashQueryBound scheme adversary q) (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary (canonicalGraphGameInputs adversary))
+    (hauxiliary : auxiliary ∈ (referenceAuxiliarySample (canonicalGraphGameInputs adversary)).support)
+    (result : Completed)
+    (hr : 𝒟[simulateQ (fixedAnswers (originalAnswers dummy adversary parameter otsSecret labels auxiliary)
+      (FtsGuessSigning.secretTable ftsSecret)) (completedRun parameter (canonicalGraphRoot labels) labels adversary)] result ≠ 0) :
+    1212415 + completedWork result ≤ q := by
+  have hv : 𝒟[referenceFamilyFrontierRest ⟨parameter, 0, otsSecret, ftsSecret⟩
+      (programmedHash parameter otsSecret ftsSecret labels
+        (finiteHashAnswer ∅ (canonicalGraphGameInputs adversary)
+          (canonicalReferenceResidual parameter (canonicalGraphGameInputs adversary)
+            (canonicalEncodingInputs_subset_gameInputs adversary parameter) labels auxiliary.rows auxiliary.seed)))
+      labels auxiliary.selections dummy adversary] (verdict result) ≠ 0 := by
+    rw [← reference_completed_verdict ⟨parameter, 0, otsSecret, ftsSecret⟩ (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary parameter) labels auxiliary hauxiliary dummy adversary, evalDist_map]
+    rw [map_eq_bind_pure_comp, RetainedObservation.bind_nonzero]
+    exact ⟨result, hr, by simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not]⟩
+  have hs := referenceResidualGame_auxiliary_support (canonicalGraphGameInputs adversary)
+    (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary parameter otsSecret ftsSecret auxiliary hauxiliary labels _ hv
+  simpa only [verdict_work] using referenceResidualGame_hashCalls_le dummy adversary q hbound (auxiliary.selections, verdict result) hs
+
+theorem fixed_original_completedRun_budget (dummy : OtsReferenceWords) (adversary : Adversary) (q : Nat)
+    (hbound : HasHashQueryBound scheme adversary q) (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (secrets : Coordinate → Digest)
+    (labels : CanonicalGraphLabels) (auxiliary : ReferenceAuxiliary (canonicalGraphGameInputs adversary))
+    (hauxiliary : auxiliary ∈ (referenceAuxiliarySample (canonicalGraphGameInputs adversary)).support)
+    (state : State Coordinate Digest PUnit) (result : Completed × State Coordinate Digest PUnit)
+    (hr : fixedRun (SecretGuessObservation.environment (originalAnswers dummy adversary parameter otsSecret labels auxiliary)) secrets
+      (completedRun parameter (canonicalGraphRoot labels) labels adversary) state result ≠ 0) :
+    1212415 + completedWork result.1 ≤ q ∧ result.2.probes ≤ state.probes + completedWork result.1 := by
+  classical
+  have hp : 𝒟[simulateQ (fixedAnswers (originalAnswers dummy adversary parameter otsSecret labels auxiliary) secrets)
+      (completedRun parameter (canonicalGraphRoot labels) labels adversary)] result.1 ≠ 0 := by
+    rw [← SecretGuessObservation.fixedRun_projection _ secrets _ state,
+      map_eq_bind_pure_comp, RetainedObservation.bind_nonzero]
+    exact ⟨result, hr, by simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not]⟩
+  have hw := original_completedWork_le dummy adversary q hbound parameter otsSecret (FtsGuessSigning.secretTable.symm secrets)
+    labels auxiliary hauxiliary result.1 hp
+  have hc := fixed_completedRun_probes
+    (SecretGuessObservation.environment (originalAnswers dummy adversary parameter otsSecret labels auxiliary)) secrets
+    parameter (canonicalGraphRoot labels) labels adversary state result hr
+  exact ⟨hw, hc⟩
+
+theorem lazy_original_completedRun_budget (dummy : OtsReferenceWords) (adversary : Adversary) (q : Nat)
+    (hbound : HasHashQueryBound scheme adversary q) (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary (canonicalGraphGameInputs adversary))
+    (hauxiliary : auxiliary ∈ (referenceAuxiliarySample (canonicalGraphGameInputs adversary)).support)
+    (result : Completed × State Coordinate Digest PUnit)
+    (hr : SecretGuessObservation.lazyRun
+      (SecretGuessObservation.environment (originalAnswers dummy adversary parameter otsSecret labels auxiliary))
+      (completedRun parameter (canonicalGraphRoot labels) labels adversary) (SecretGuessObservation.initialState PUnit.unit) result ≠ 0) :
+    1212415 + completedWork result.1 ≤ q ∧ result.2.probes ≤ completedWork result.1 := by
+  rw [← SecretGuessObservation.run_erasure _ _ _ (fun _ => Finset.univ_nonempty), RetainedObservation.bind_nonzero] at hr
+  obtain ⟨secrets, _, hr⟩ := hr
+  have h := fixed_original_completedRun_budget dummy adversary q hbound parameter otsSecret secrets labels auxiliary hauxiliary
+    (SecretGuessObservation.initialState PUnit.unit) result hr
+  simpa only [SecretGuessObservation.initialState, Nat.zero_add] using h
+
+theorem lazy_original_completedRun_probes (dummy : OtsReferenceWords) (adversary : Adversary) (q : Nat)
+    (hbound : HasHashQueryBound scheme adversary q) (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary (canonicalGraphGameInputs adversary))
+    (hauxiliary : auxiliary ∈ (referenceAuxiliarySample (canonicalGraphGameInputs adversary)).support)
+    (result : Completed × State Coordinate Digest PUnit)
+    (hr : SecretGuessObservation.lazyRun
+      (SecretGuessObservation.environment (originalAnswers dummy adversary parameter otsSecret labels auxiliary))
+      (completedRun parameter (canonicalGraphRoot labels) labels adversary) (SecretGuessObservation.initialState PUnit.unit) result ≠ 0) :
+    1212415 + result.2.probes ≤ q := by
+  obtain ⟨hw, hp⟩ := lazy_original_completedRun_budget dummy adversary q hbound parameter otsSecret labels auxiliary hauxiliary result hr
+  omega
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessCachedForced.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessCachedForced.lean
new file mode 100644
index 000000000..9c5198060
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessCachedForced.lean
@@ -0,0 +1,230 @@
+import SphincsSecurity.Proof.Forced.FtsGuessCachedMessage
+import SphincsSecurity.Proof.Residual.RetainedResidualCoverageStep
+
+/-! ## FtsGuessSigningDigest -/
+
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs publicDigestLoop signDigestLoop
+
+theorem publicSigningWork_complete_digest (key : SecretKey) (known : Labels) (words : OtsReferenceWords)
+    (selections : ReferenceFamily) (actual : Labels) (message : Message) (cache : QueryCache HashSpec) :
+    (fun result => ((completePublicSigningRecord (fun index tree leaf => actual (.ftsStart index tree leaf)) result.1.1).1, result.2)) <$>
+      𝒟[(simulateQ romImpl (ResidualByteFrontend.publicSigningWork key.parameter key.root known words selections message)).run cache] =
+        RetainedResidual.digestCompletionValue known words selections actual <$>
+          𝒟[(simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run cache] := by
+  rw [RetainedResidual.publicSigningWork_eq_digestWork, simulateQ_map, StateT.run_map, evalDist_map,
+    Functor.map_map, publicDigestLoop_eq, simulateQ_boundaryComputation]
+  rw [← boundaryRun_forget key.parameter (signDigestLoop digestAttemptLimit key message) cache,
+    evalDist_map, Functor.map_map]
+  change (fun result => ((completePublicSigningRecord (fun index tree leaf => actual (.ftsStart index tree leaf))
+    (RetainedResidual.digestWork known words selections result.1).1).1, result.2)) <$>
+      𝒟[boundaryRun key.parameter (signDigestLoop digestAttemptLimit key message) cache] = _
+  congr 1
+  funext result
+  rcases result with ⟨⟨selected, trace⟩, after⟩
+  cases selected <;> rfl
+
+end SphincsSecurity.Concrete.FtsGuessHash
+
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec UniformTableCompletion
+open FtsGuessSigning (Coordinate)
+open SecretGuessObservation (State initialState forcedRun forcedProgram forcedTrial plainAfterTrial plainAfterDisclosure)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  publicDigestLoop canonicalGraphRoot canonicalGraphInput
+
+abbrev CachedState := QueryCache HashSpec × State Coordinate Digest PUnit
+
+variable (parameter : PublicParameter) (root : Digest)
+  (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+  (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+  (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (dummy : OtsReferenceWords) (slot : Nat)
+
+noncomputable def seedProgram (input : Auxiliary.Domain) : OracleComp (ForcedSeedSpec inputs) (Auxiliary.Range input) :=
+  simulateQ (seedLift inputs) (referenceProgram parameter root otsSecret labels inputs hencoding selections rows dummy input)
+
+noncomputable def cachedAuxiliary (input : Auxiliary.Domain) (cache : QueryCache HashSpec) :
+    SPMF (Auxiliary.Range input × QueryCache HashSpec) :=
+  cachedSeedRun inputs (seedProgram parameter root otsSecret labels inputs hencoding selections rows dummy input) cache
+
+noncomputable def cachedForcedImpl : QueryImpl World (StateT CachedState SPMF)
+  | .inl input => StateT.mk fun state => (fun result => (result.1, (result.2, state.2))) <$>
+      cachedAuxiliary parameter root otsSecret labels inputs hencoding selections rows dummy input state.1
+  | .inr (.inl (coordinate, candidate)) => StateT.mk fun state =>
+      (fun hit => (hit, (state.1, plainAfterTrial state.2 coordinate candidate hit))) <$>
+        forcedTrial slot state.2 coordinate candidate
+  | .inr (.inr coordinate) => StateT.mk fun state =>
+      (fun value => (value, (state.1, plainAfterDisclosure state.2 coordinate value))) <$> cell (state.2.allowed coordinate)
+
+noncomputable def cachedForcedRun {Result : Type} (computation : OracleComp World Result) (state : CachedState) :
+    SPMF (Result × CachedState) :=
+  (simulateQ (cachedForcedImpl parameter root otsSecret labels inputs hencoding selections rows dummy slot) computation).run state
+
+theorem cachedForcedRun_pure {Result : Type} (value : Result) (state : CachedState) :
+    cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot (pure value) state =
+      pure (value, state) := by
+  simp only [cachedForcedRun, simulateQ_pure, StateT.run_pure]
+
+theorem cachedForcedRun_query_bind {Result : Type} (input : World.Domain)
+    (next : World.Range input → OracleComp World Result) (state : CachedState) :
+    cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+      (liftM (World.query input) >>= next) state =
+      ((cachedForcedImpl parameter root otsSecret labels inputs hencoding selections rows dummy slot input).run state >>=
+        fun result => cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+          (next result.1) result.2) := by
+  simp only [cachedForcedRun, simulateQ_bind, simulateQ_spec_query, StateT.run_bind]
+
+theorem cachedForcedRun_bind {First Result : Type} (first : OracleComp World First)
+    (next : First → OracleComp World Result) (state : CachedState) :
+    cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot (first >>= next) state =
+      (cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot first state >>=
+        fun middle => cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+          (next middle.1) middle.2) := by
+  simp only [cachedForcedRun, simulateQ_bind, StateT.run_bind]
+
+theorem cachedSeedRun_pure {Result : Type} (value : Result) (cache : QueryCache HashSpec) :
+    cachedSeedRun inputs (pure value : OracleComp (ForcedSeedSpec inputs) Result) cache = pure (value, cache) := by
+  simp only [cachedSeedRun, simulateQ_pure, StateT.run_pure]
+
+theorem cachedSeedRun_bind {First Result : Type} (first : OracleComp (ForcedSeedSpec inputs) First)
+    (next : First → OracleComp (ForcedSeedSpec inputs) Result) (cache : QueryCache HashSpec) :
+    cachedSeedRun inputs (first >>= next) cache =
+      (cachedSeedRun inputs first cache >>= fun middle => cachedSeedRun inputs (next middle.1) middle.2) := by
+  simp only [cachedSeedRun, simulateQ_bind, StateT.run_bind]
+
+theorem cachedSeedRun_sampleForcedBool (law : SPMF Bool) (cache : QueryCache HashSpec) :
+    cachedSeedRun inputs (sampleForcedBool inputs law) cache = (fun hit => (hit, cache)) <$> law := by
+  rw [cachedSeedRun, sampleForcedBool, simulateQ_spec_query]
+  rfl
+
+theorem cachedSeedRun_sampleForcedDigest (law : SPMF Digest) (cache : QueryCache HashSpec) :
+    cachedSeedRun inputs (sampleForcedDigest inputs law) cache = (fun value => (value, cache)) <$> law := by
+  rw [cachedSeedRun, sampleForcedDigest, simulateQ_spec_query]
+  rfl
+
+/-- Running the forced interpreter against the actual cached seed table is the seed-program run in `cachedSeedRun`, with the secret-guess state carried alongside the cache. -/
+theorem cachedForcedRun_seed {Result : Type} (computation : OracleComp World Result)
+    (cache : QueryCache HashSpec) (state : State Coordinate Digest PUnit) :
+    cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot computation (cache, state) =
+      (fun result => (result.1.1, (result.2, result.1.2))) <$>
+        cachedSeedRun inputs (forcedProgram (seedProgram parameter root otsSecret labels inputs hencoding selections rows dummy)
+          (sampleForcedBool inputs) (sampleForcedDigest inputs) slot computation state) cache := by
+  induction computation using OracleComp.inductionOn generalizing cache state with
+  | pure value =>
+      rw [cachedForcedRun_pure, SecretGuessObservation.forcedProgram_pure, cachedSeedRun_pure, map_pure]
+  | query_bind input next ih =>
+      rw [cachedForcedRun_query_bind, SecretGuessObservation.forcedProgram_query_bind]
+      cases input with
+      | inl input =>
+          rw [cachedSeedRun_bind, map_bind]
+          simp only [cachedForcedImpl, StateT.run_mk, bind_map_left, cachedAuxiliary]
+          apply congrArg (cachedSeedRun inputs (seedProgram parameter root otsSecret labels inputs hencoding selections rows dummy input) cache >>= ·)
+          funext answer
+          exact ih answer.1 answer.2 state
+      | inr input =>
+          cases input with
+          | inl probe =>
+              rcases probe with ⟨coordinate, candidate⟩
+              rw [cachedSeedRun_bind, cachedSeedRun_sampleForcedBool, map_bind]
+              simp only [cachedForcedImpl, StateT.run_mk, bind_map_left]
+              apply congrArg (forcedTrial slot state coordinate candidate >>= ·)
+              funext hit
+              exact ih hit cache (plainAfterTrial state coordinate candidate hit)
+          | inr coordinate =>
+              rw [cachedSeedRun_bind, cachedSeedRun_sampleForcedDigest, map_bind]
+              simp only [cachedForcedImpl, StateT.run_mk, bind_map_left]
+              apply congrArg (cell (state.allowed coordinate) >>= ·)
+              funext value
+              exact ih value cache (plainAfterDisclosure state coordinate value)
+
+theorem seedAllowed_empty : seedAllowed inputs ∅ = fun _ => Finset.univ := by
+  funext input
+  simp only [seedAllowed, QueryCache.empty_apply, Option.elim_none]
+
+/-- Starting from the empty cache, forgetting the cache recovers the deferred forced run. -/
+theorem cachedForcedRun_deferred (adversary : Adversary) :
+    (fun result => (result.1, result.2.2)) <$>
+      cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+        (completedRun parameter root labels adversary) (∅, initialState PUnit.unit) =
+      Prod.fst <$> deferredForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot adversary := by
+  rw [cachedForcedRun_seed, Functor.map_map, deferredForcedRun, ← seedAllowed_empty inputs, ← cachedSeedRun_project,
+    Functor.map_map]
+  rfl
+
+theorem cachedForcedRun_original_budget (dummy : OtsReferenceWords) (adversary : Adversary) (q slot : Nat)
+    (hbound : HasHashQueryBound scheme adversary q) (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary (canonicalGraphGameInputs adversary))
+    (hauxiliary : auxiliary ∈ (referenceAuxiliarySample (canonicalGraphGameInputs adversary)).support)
+    (result : Completed × CachedState)
+    (hr : cachedForcedRun parameter (canonicalGraphRoot labels) otsSecret labels (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary parameter) auxiliary.selections auxiliary.rows dummy slot
+      (completedRun parameter (canonicalGraphRoot labels) labels adversary) (∅, initialState PUnit.unit) result ≠ 0) :
+    1212415 + completedWork result.1 ≤ q ∧ result.2.2.probes ≤ completedWork result.1 := by
+  have hp : (Prod.fst <$> deferredForcedRun parameter (canonicalGraphRoot labels) otsSecret labels
+      (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary parameter)
+      auxiliary.selections auxiliary.rows dummy slot adversary) (result.1, result.2.2) ≠ 0 := by
+    rw [← cachedForcedRun_deferred, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero]
+    exact ⟨result, hr, by simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not]⟩
+  rw [map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hp
+  obtain ⟨deferred, hdeferred, heq⟩ := hp
+  simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at heq
+  have h := deferredForcedRun_original_budget dummy adversary q slot hbound parameter otsSecret labels auxiliary hauxiliary
+    deferred hdeferred
+  rw [← heq] at h
+  exact h
+
+theorem referenceAuxiliary_mem_support (inputs : Finset HashInput) (selections : ReferenceFamily)
+    (hselections : selections ∈ (FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit).support)
+    (rows : EncodingPosition → Fin encodingAttemptLimit → HashOutput)
+    (hrows : rows ∈ (FirstSuccessFamily.afterSelect decodeEncodingOutput encodingAttemptLimit
+      decodeEncodingOutput_invalid_nonempty selections).support) (seed : inputs → HashOutput) :
+    (⟨selections, Function.uncurry rows, seed⟩ : ReferenceAuxiliary inputs) ∈ (referenceAuxiliarySample inputs).support := by
+  rw [referenceAuxiliarySample, PMF.mem_support_bind_iff]
+  refine ⟨selections, hselections, ?_⟩
+  rw [PMF.mem_support_bind_iff]
+  refine ⟨rows, hrows, ?_⟩
+  rw [PMF.mem_support_map_iff]
+  exact ⟨seed, PMF.mem_support_uniformOfFintype seed, rfl⟩
+
+noncomputable def cachedNearGame (dummy : OtsReferenceWords) (adversary : Adversary) (slot : Nat) : SPMF Bool := do
+  let parameter ← 𝒟[sampleParameter]
+  let otsSecret ← 𝒟[sampleOtsSecrets]
+  let selections ← 𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit]
+  let rows ← 𝒟[FirstSuccessFamily.afterSelect decodeEncodingOutput encodingAttemptLimit decodeEncodingOutput_invalid_nonempty selections]
+  let labels ← 𝒟[PMF.uniformOfFintype CanonicalGraphLabels]
+  (fun result => decide (completedNearCertificate parameter (canonicalGraphRoot labels) result.1)) <$>
+    cachedForcedRun parameter (canonicalGraphRoot labels) otsSecret labels (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary parameter) selections (Function.uncurry rows) dummy slot
+      (completedRun parameter (canonicalGraphRoot labels) labels adversary) (∅, initialState PUnit.unit)
+
+theorem forcedNearGame_cached (dummy : OtsReferenceWords) (adversary : Adversary) (slot : Nat) :
+    forcedNearGame dummy adversary slot = cachedNearGame dummy adversary slot := by
+  rw [forcedNearGame_deferred]
+  simp only [forcedNearDeferredGame, cachedNearGame]
+  apply congrArg (𝒟[sampleParameter] >>= ·)
+  funext parameter
+  apply congrArg (𝒟[sampleOtsSecrets] >>= ·)
+  funext otsSecret
+  apply congrArg (𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit] >>= ·)
+  funext selections
+  apply congrArg (𝒟[FirstSuccessFamily.afterSelect decodeEncodingOutput encodingAttemptLimit
+    decodeEncodingOutput_invalid_nonempty selections] >>= ·)
+  funext rows
+  apply congrArg (𝒟[PMF.uniformOfFintype CanonicalGraphLabels] >>= ·)
+  funext labels
+  have h := congrArg (Functor.map (fun result : Completed × State Coordinate Digest PUnit =>
+    decide (completedNearCertificate parameter (canonicalGraphRoot labels) result.1)))
+    (cachedForcedRun_deferred parameter (canonicalGraphRoot labels) otsSecret labels (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary parameter) selections (Function.uncurry rows) dummy slot adversary)
+  simp only [Functor.map_map] at h
+  exact h.symm
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessCachedMessage.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessCachedMessage.lean
new file mode 100644
index 000000000..5e287382a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessCachedMessage.lean
@@ -0,0 +1,80 @@
+import SphincsSecurity.Proof.Forced.FtsGuessSeedCache
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open FtsProbeSimulation (MessageHashInput)
+open ResidualByteFrontend (MessageOnly)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs publicDigestLoop
+
+theorem cached_residualWorld_query (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (known : Labels) (rows : CanonicalEncodingRows)
+    (input : OracleWorld.Domain) (cache : QueryCache HashSpec)
+    (hinput : ∀ hash, input = .inr hash → hash ∈ inputs ∧ MessageHashInput parameter hash) :
+    cachedSeedRun inputs (simulateQ (seedLift inputs) (residualWorld parameter inputs hencoding known rows input)) cache =
+      𝒟[(romImpl input).run cache] := by
+  cases input with
+  | inl input =>
+      simp [residualWorld, seedLift, cachedSeedRun, cachedSeedImpl, forcedSeedAuxiliary,
+        romImpl, unifFwdImpl, QueryImpl.liftTarget, HasQuery.toQueryImpl, StateT.run_monadLift]
+  | inr input =>
+      obtain ⟨hin, hm⟩ := hinput input rfl
+      rw [residualWorld_message parameter inputs hencoding known rows ⟨input, hin⟩ hm,
+        simulateQ_spec_query, seedLift, cachedSeedRun, simulateQ_spec_query]
+      rfl
+
+theorem cached_residualWorld_run {Result : Type} (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (known : Labels) (rows : CanonicalEncodingRows)
+    (computation : OracleComp OracleWorld Result) (cache : QueryCache HashSpec)
+    (hmessage : MessageOnly parameter computation) (hinputs : hashInputs computation ⊆ inputs) :
+    cachedSeedRun inputs (simulateQ (seedLift inputs)
+      (simulateQ (residualWorld parameter inputs hencoding known rows) computation)) cache =
+      𝒟[(simulateQ romImpl computation).run cache] := by
+  induction computation using OracleComp.inductionOn generalizing cache with
+  | pure value => simp only [simulateQ_pure, cachedSeedRun, simulateQ_pure, StateT.run_pure, evalDist_pure]
+  | query_bind input next ih =>
+      simp only [simulateQ_bind, simulateQ_spec_query, cachedSeedRun, StateT.run_bind, evalDist_bind]
+      change (cachedSeedRun inputs (simulateQ (seedLift inputs)
+        (residualWorld parameter inputs hencoding known rows input)) cache >>= fun result =>
+          cachedSeedRun inputs (simulateQ (seedLift inputs)
+            (simulateQ (residualWorld parameter inputs hencoding known rows) (next result.1))) result.2) = _
+      rw [cached_residualWorld_query parameter inputs hencoding known rows input cache (by
+        intro hash heq
+        subst input
+        have hi := mem_hashInputs_hash_bind hash next
+        exact ⟨hinputs hi, hmessage hash hi⟩)]
+      apply congrArg (𝒟[(romImpl input).run cache] >>= ·)
+      funext result
+      exact ih result.1 result.2
+        (fun hash hh => hmessage hash ((hashInputs_next_subset input next result.1) hh))
+        ((hashInputs_next_subset input next result.1).trans hinputs)
+
+theorem publicRecordProgram_eq_work {TargetIndex : Type} {targetSpec : OracleSpec TargetIndex}
+    (parameter : PublicParameter) (root : Digest) (outside : QueryImpl OracleWorld (OracleComp targetSpec))
+    (known : Labels) (words : OtsReferenceWords) (selections : ReferenceFamily) (message : Message) :
+    publicRecordProgram parameter root outside known words selections message =
+      simulateQ outside (Prod.fst <$> ResidualByteFrontend.publicSigningWork parameter root known words selections message) := by
+  rw [publicRecordProgram, ResidualByteFrontend.publicSigningWork, map_bind, simulateQ_bind]
+  change (simulateQ outside (boundaryComputation parameter (publicDigestLoop parameter root message digestAttemptLimit)) >>= _) = _
+  apply congrArg (simulateQ outside (boundaryComputation parameter (publicDigestLoop parameter root message digestAttemptLimit)) >>= ·)
+  funext selected
+  cases selected.1 <;> rfl
+
+theorem cached_reference_signing_record (parameter : PublicParameter) (root : Digest)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+    (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+    (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (dummy : OtsReferenceWords)
+    (message : Message) (cache : QueryCache HashSpec)
+    (hinputs : hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs) :
+    cachedSeedRun inputs (simulateQ (seedLift inputs)
+      (referenceProgram parameter root otsSecret labels inputs hencoding selections rows dummy (.inr message))) cache =
+      𝒟[(simulateQ romImpl (Prod.fst <$> ResidualByteFrontend.publicSigningWork parameter root (known otsSecret labels)
+        (referenceFamilyWords selections dummy) selections message)).run cache] := by
+  rw [referenceProgram, publicRecordProgram_eq_work]
+  apply cached_residualWorld_run
+  · exact ResidualByteFrontend.messageOnly_map parameter Prod.fst _
+      (ResidualByteFrontend.publicSigningWork_messageOnly parameter root _ _ selections message)
+  · rwa [ResidualByteFrontend.hashInputs_map, ResidualByteFrontend.hashInputs_publicSigningWork]
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessCachedSigning.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessCachedSigning.lean
new file mode 100644
index 000000000..d6008212f
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessCachedSigning.lean
@@ -0,0 +1,354 @@
+import SphincsSecurity.Proof.Forced.FtsGuessCachedForced
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec UniformTableCompletion CanonicalProbeRouting
+open FtsGuessSigning (Coordinate)
+open FtsProbeSimulation (MessageHashInput messageAnswers)
+open SecretGuessObservation (State forcedRun lazyRun fixedRun disclosure environment plainAfterDisclosure)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  publicDigestLoop canonicalGraphRoot canonicalGraphInput
+
+theorem map_nonzero_of {A B : Type} (law : SPMF A) (f : A → B) (value : A) (hvalue : law value ≠ 0) :
+    (f <$> law) (f value) ≠ 0 := by
+  rw [map_eq_bind_pure_comp, RetainedObservation.bind_nonzero]
+  exact ⟨value, hvalue, by simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not]⟩
+
+theorem map_nonzero_source' {A B : Type} (law : SPMF A) (f : A → B) (result : B)
+    (hresult : (f <$> law) result ≠ 0) : ∃ source, law source ≠ 0 ∧ result = f source := by
+  rw [map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨source, hsource, hresult⟩ := hresult
+  exact ⟨source, hsource, by simpa only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] using hresult⟩
+
+variable (parameter : PublicParameter) (root : Digest)
+  (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+  (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+  (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (dummy : OtsReferenceWords) (slot : Nat)
+
+theorem cachedForcedRun_query (input : World.Domain) (state : CachedState) :
+    cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot (liftM (World.query input)) state =
+      (cachedForcedImpl parameter root otsSecret labels inputs hencoding selections rows dummy slot input).run state := by
+  rw [← bind_pure (liftM (World.query input)), cachedForcedRun_query_bind]
+  simp only [cachedForcedRun_pure, Prod.mk.eta, bind_pure]
+
+/-! ### Fixed-seed support -/
+
+theorem seedAllowed_nonempty (cache : QueryCache HashSpec) (input : inputs) : (seedAllowed inputs cache input).Nonempty := by
+  unfold seedAllowed
+  cases cache input.val <;> simp
+
+theorem seedProgram_forced_fixed {Result : Type} (seed : inputs → HashOutput) (computation : OracleComp World Result)
+    (state : State Coordinate Digest PUnit) :
+    simulateQ (UniformTableObservation.fixedImpl forcedSeedAuxiliary seed)
+      (SecretGuessObservation.forcedProgram (seedProgram parameter root otsSecret labels inputs hencoding selections rows dummy)
+        (sampleForcedBool inputs) (sampleForcedDigest inputs) slot computation state) =
+      forcedRun (environment (referenceAnswers parameter root otsSecret labels inputs hencoding ⟨selections, rows, seed⟩ dummy)) slot
+        computation state := by
+  apply SecretGuessObservation.simulateQ_forcedProgram
+  · intro input
+    rw [seedProgram, seedLift_fixed, referenceProgram_fixed]
+  · intro law
+    simp only [sampleForcedBool, simulateQ_spec_query, UniformTableObservation.fixedImpl, forcedSeedAuxiliary]
+  · intro law
+    simp only [sampleForcedDigest, simulateQ_spec_query, UniformTableObservation.fixedImpl, forcedSeedAuxiliary]
+
+/-- A supported cached run is a supported fixed-seed forced run for some seed agreeing with the initial cache. -/
+theorem cachedForcedRun_fixed_seed {Result : Type} (computation : OracleComp World Result)
+    (cache : QueryCache HashSpec) (state : State Coordinate Digest PUnit) (result : Result × CachedState)
+    (hr : cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot computation (cache, state) result ≠ 0) :
+    ∃ seed : inputs → HashOutput, (∀ (input : inputs) (output : HashOutput), cache input.val = some output → seed input = output) ∧
+      forcedRun (environment (referenceAnswers parameter root otsSecret labels inputs hencoding ⟨selections, rows, seed⟩ dummy)) slot
+        computation state (result.1, result.2.2) ≠ 0 := by
+  rw [cachedForcedRun_seed] at hr
+  obtain ⟨raw, hraw, heq⟩ := map_nonzero_source' _ _ _ hr
+  have hproj := map_nonzero_of _ (Prod.map id (seedAllowed inputs)) raw hraw
+  rw [cachedSeedRun_project, ← UniformTableObservation.run_erasure _ _ _ (seedAllowed_nonempty inputs cache),
+    RetainedObservation.bind_nonzero] at hproj
+  obtain ⟨seed, hseed, hobserved⟩ := hproj
+  refine ⟨seed, ?_, ?_⟩
+  · intro input output houtput
+    rw [complete_apply] at hseed
+    split_ifs at hseed with hmem
+    · have h := hmem input
+      simpa only [seedAllowed, houtput, Option.elim_some, Finset.mem_singleton] using h
+    · exact absurd rfl hseed
+  · have h := map_nonzero_of _ Prod.fst _ hobserved
+    rw [UniformTableObservation.observedRun_forget, seedProgram_forced_fixed] at h
+    simpa only [heq, Prod.map_fst, id_eq] using h
+
+theorem cachedForcedRun_nonempty {Result : Type} (computation : OracleComp World Result)
+    (cache : QueryCache HashSpec) (state : State Coordinate Digest PUnit)
+    (ha : ∀ coordinate, (state.allowed coordinate).Nonempty) (result : Result × CachedState)
+    (hr : cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot computation (cache, state) result ≠ 0) :
+    ∀ coordinate, (result.2.2.allowed coordinate).Nonempty := by
+  obtain ⟨seed, _, hforced⟩ := cachedForcedRun_fixed_seed parameter root otsSecret labels inputs hencoding selections rows dummy slot
+    computation cache state result hr
+  exact SecretGuessObservation.forcedRun_nonempty _ slot computation state ha _ hforced
+
+/-! ### Auxiliary hash queries -/
+
+theorem cachedAuxiliary_unif (sample : unifSpec.Domain) (cache : QueryCache HashSpec) :
+    cachedAuxiliary parameter root otsSecret labels inputs hencoding selections rows dummy (.inl (.inl sample)) cache =
+      (fun answer => (answer, cache)) <$> 𝒟[(liftM (unifSpec.query sample) : ProbComp _)] := by
+  rw [cachedAuxiliary, seedProgram]
+  change cachedSeedRun inputs (simulateQ (seedLift inputs) (liftM ((SeedSpec inputs).query (.inl sample)))) cache = _
+  rw [simulateQ_spec_query, seedLift, cachedSeedRun, simulateQ_spec_query]
+  rfl
+
+theorem cachedAuxiliary_message (input : inputs) (hmessage : MessageHashInput parameter input.val) (cache : QueryCache HashSpec) :
+    cachedAuxiliary parameter root otsSecret labels inputs hencoding selections rows dummy (.inl (.inr input.val)) cache =
+      𝒟[(romImpl (.inr input.val)).run cache] := by
+  rw [cachedAuxiliary, seedProgram,
+    referenceProgram_message parameter root otsSecret labels inputs hencoding selections rows dummy input hmessage,
+    simulateQ_spec_query, seedLift, cachedSeedRun, simulateQ_spec_query]
+  rfl
+
+/-- One seed-table hash cell at `input` moves the cache at most at `input`, never removes rows, and adds at most one. -/
+theorem cachedSeedRun_residualProgram_support {Row : Type} (embed : Row → inputs) (table : Row → HashOutput)
+    (input : HashInput) (cache : QueryCache HashSpec) (result : HashOutput × QueryCache HashSpec)
+    (hr : cachedSeedRun inputs (simulateQ (seedLift inputs) (residualProgram inputs embed table input)) cache result ≠ 0) :
+    (∀ other, other ≠ input → result.2 other = cache other) ∧ cache ≤ result.2 ∧
+      QueryCache.enncard result.2 ≤ QueryCache.enncard cache + 1 := by
+  by_cases hi : input ∈ inputs
+  · rw [residualProgram, dif_pos hi] at hr
+    by_cases hrange : (⟨input, hi⟩ : inputs) ∈ Set.range embed
+    · rw [dif_pos hrange, simulateQ_pure, cachedSeedRun_pure] at hr
+      simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+      subst result
+      exact ⟨fun _ _ => rfl, le_rfl, le_self_add⟩
+    · rw [dif_neg hrange, simulateQ_spec_query, seedLift, cachedSeedRun, simulateQ_spec_query] at hr
+      change 𝒟[(randomOracle (spec := HashSpec) input).run cache] result ≠ 0 at hr
+      have hmem : result ∈ support ((randomOracle (spec := HashSpec) input).run cache) :=
+        (mem_support_iff_evalDist_apply_ne_zero _ _).mpr hr
+      cases hc : cache input with
+      | some output =>
+          rw [randomOracle, QueryImpl.withCaching_run_some _ hc, mem_support_pure_iff] at hmem
+          subst result
+          exact ⟨fun _ _ => rfl, le_rfl, le_self_add⟩
+      | none =>
+          rw [randomOracle, QueryImpl.withCaching_run_none _ hc, support_map] at hmem
+          obtain ⟨output, _, rfl⟩ := hmem
+          refine ⟨fun other hne => QueryCache.cacheQuery_of_ne cache output hne, QueryCache.le_cacheQuery cache hc, ?_⟩
+          exact (enncard_cacheQuery_of_fresh cache input output hc).le
+  · rw [residualProgram, dif_neg hi, simulateQ_pure, cachedSeedRun_pure] at hr
+    simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+    subst result
+    exact ⟨fun _ _ => rfl, le_rfl, le_self_add⟩
+
+theorem cachedAuxiliary_hash_support (input : HashInput) (cache : QueryCache HashSpec)
+    (result : HashOutput × QueryCache HashSpec)
+    (hr : cachedAuxiliary parameter root otsSecret labels inputs hencoding selections rows dummy (.inl (.inr input)) cache result ≠ 0) :
+    (∀ other, other ≠ input → result.2 other = cache other) ∧ cache ≤ result.2 ∧
+      QueryCache.enncard result.2 ≤ QueryCache.enncard cache + 1 := by
+  rw [cachedAuxiliary, seedProgram] at hr
+  change cachedSeedRun inputs (simulateQ (seedLift inputs) (auxiliaryHashProgram parameter otsSecret labels inputs hencoding rows input)) cache
+    result ≠ 0 at hr
+  have hpure (value : HashOutput) (hp : cachedSeedRun inputs (simulateQ (seedLift inputs) (pure value)) cache result ≠ 0) :
+      (∀ other, other ≠ input → result.2 other = cache other) ∧ cache ≤ result.2 ∧
+        QueryCache.enncard result.2 ≤ QueryCache.enncard cache + 1 := by
+    rw [simulateQ_pure, cachedSeedRun_pure] at hp
+    simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hp
+    subst result
+    exact ⟨fun _ _ => rfl, le_rfl, le_self_add⟩
+  unfold auxiliaryHashProgram at hr
+  cases hp : FtsProbeSimulation.decodeProbe? parameter input with
+  | some probe =>
+      rw [hp] at hr
+      exact cachedSeedRun_residualProgram_support inputs _ rows input cache result hr
+  | none =>
+      rw [hp] at hr
+      cases hd : decodePosition parameter input with
+      | none =>
+          rw [hd] at hr
+          exact cachedSeedRun_residualProgram_support inputs _ rows input cache result hr
+      | some position =>
+          rw [hd] at hr
+          dsimp only at hr
+          split_ifs at hr with hcanonical
+          · exact hpure _ hr
+          · exact cachedSeedRun_residualProgram_support inputs _ rows input cache result hr
+
+/-! ### World queries -/
+
+theorem cachedForcedRun_world_unif (sample : unifSpec.Domain) (cache : QueryCache HashSpec)
+    (state : State Coordinate Digest PUnit) :
+    cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+      (worldProgram parameter labels (.inl sample)) (cache, state) =
+      (fun answer => (answer, (cache, state))) <$> 𝒟[(liftM (unifSpec.query sample) : ProbComp _)] := by
+  rw [worldProgram, cachedForcedRun_query]
+  simp only [cachedForcedImpl, StateT.run_mk, cachedAuxiliary_unif, Functor.map_map]
+
+theorem cachedForcedRun_world_message (input : HashInput) (hin : input ∈ inputs) (hmessage : MessageHashInput parameter input)
+    (cache : QueryCache HashSpec) (state : State Coordinate Digest PUnit) :
+    cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+      (worldProgram parameter labels (.inr input)) (cache, state) =
+      (fun result => (result.1, (result.2, state))) <$> 𝒟[(romImpl (.inr input)).run cache] := by
+  rw [worldProgram, hashProgram, message_not_probe parameter input hmessage]
+  rw [cachedForcedRun_query]
+  simp only [cachedForcedImpl, StateT.run_mk]
+  rw [cachedAuxiliary_message parameter root otsSecret labels inputs hencoding selections rows dummy ⟨input, hin⟩ hmessage cache]
+  rfl
+
+theorem cachedForcedRun_world_hash_support (input : HashInput) (cache : QueryCache HashSpec)
+    (state : State Coordinate Digest PUnit) (result : HashOutput × CachedState)
+    (hr : cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+      (worldProgram parameter labels (.inr input)) (cache, state) result ≠ 0) :
+    (∀ other, other ≠ input → result.2.1 other = cache other) ∧ cache ≤ result.2.1 ∧
+      QueryCache.enncard result.2.1 ≤ QueryCache.enncard cache + 1 := by
+  have haux (current : State Coordinate Digest PUnit)
+      (h : cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+        (liftM (World.query (.inl (.inl (.inr input))))) (cache, current) result ≠ 0) :
+      (∀ other, other ≠ input → result.2.1 other = cache other) ∧ cache ≤ result.2.1 ∧
+        QueryCache.enncard result.2.1 ≤ QueryCache.enncard cache + 1 := by
+    rw [cachedForcedRun_query] at h
+    simp only [cachedForcedImpl, StateT.run_mk] at h
+    obtain ⟨raw, hraw, heq⟩ := map_nonzero_source' _ _ _ h
+    subst result
+    exact cachedAuxiliary_hash_support parameter root otsSecret labels inputs hencoding selections rows dummy input cache raw hraw
+  rw [worldProgram, hashProgram] at hr
+  cases hp : FtsProbeSimulation.decodeProbe? parameter input with
+  | none =>
+      rw [hp] at hr
+      exact haux state hr
+  | some probe =>
+      rw [hp, cachedForcedRun_query_bind] at hr
+      simp only [cachedForcedImpl, StateT.run_mk] at hr
+      rw [RetainedObservation.bind_nonzero] at hr
+      obtain ⟨middle, hmiddle, hr⟩ := hr
+      obtain ⟨hit, _, rfl⟩ := map_nonzero_source' _ _ _ hmiddle
+      dsimp only at hr
+      split_ifs at hr with hhit
+      · rw [cachedForcedRun_pure] at hr
+        simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+        subst result
+        exact ⟨fun _ _ => rfl, le_rfl, le_self_add⟩
+      · exact haux _ hr
+
+theorem messageAnswers_eq_of_cache_of_ne (cache after : QueryCache HashSpec) (input : HashInput)
+    (hmessage : ¬MessageHashInput parameter input) (hother : ∀ other, other ≠ input → after other = cache other) :
+    messageAnswers parameter after = messageAnswers parameter cache := by
+  funext payload
+  apply hother
+  intro heq
+  exact hmessage ⟨payload, heq⟩
+
+/-! ### Signing -/
+
+theorem lazyRun_bind {First Result : Type} (auxiliary : QueryImpl Auxiliary ProbComp) (first : OracleComp World First)
+    (next : First → OracleComp World Result) (state : State Coordinate Digest PUnit) :
+    lazyRun (environment auxiliary) (first >>= next) state =
+      (lazyRun (environment auxiliary) first state >>= fun middle => lazyRun (environment auxiliary) (next middle.1) middle.2) :=
+  runWith_bind _ first next state
+
+theorem lazyRun_pure {Result : Type} (auxiliary : QueryImpl Auxiliary ProbComp) (value : Result)
+    (state : State Coordinate Digest PUnit) :
+    lazyRun (environment auxiliary) (pure value) state = pure (value, state) :=
+  SecretGuessObservation.runWith_pure _ value state
+
+theorem lazyRun_disclosure_bind {Result : Type} (auxiliary : QueryImpl Auxiliary ProbComp) (coordinate : Coordinate)
+    (next : Digest → OracleComp World Result) (state : State Coordinate Digest PUnit) :
+    lazyRun (environment auxiliary) (disclosure coordinate >>= next) state =
+      (cell (state.allowed coordinate) >>= fun value =>
+        lazyRun (environment auxiliary) (next value) (plainAfterDisclosure state coordinate value)) := by
+  rw [disclosure, lazyRun, SecretGuessObservation.runWith_query_bind]
+  simp only [SecretGuessObservation.lazyImpl, StateT.run_mk, bind_map_left]
+  rfl
+
+theorem cachedForcedRun_disclosure_bind {Result : Type} (coordinate : Coordinate)
+    (next : Digest → OracleComp World Result) (cache : QueryCache HashSpec) (state : State Coordinate Digest PUnit) :
+    cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot (disclosure coordinate >>= next) (cache, state) =
+      (cell (state.allowed coordinate) >>= fun value =>
+        cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot (next value)
+          (cache, plainAfterDisclosure state coordinate value)) := by
+  rw [disclosure, cachedForcedRun_query_bind]
+  simp only [cachedForcedImpl, StateT.run_mk, bind_map_left]
+  rfl
+
+theorem cachedForcedRun_disclosureSequence {Result : Type} {n : Nat} (coordinates : Fin n → Coordinate)
+    (next : (Fin n → Digest) → OracleComp World Result) (cache : QueryCache HashSpec)
+    (state : State Coordinate Digest PUnit) (auxiliary : QueryImpl Auxiliary ProbComp) :
+    cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+      ((sequenceFin fun index => disclosure (coordinates index)) >>= next) (cache, state) =
+      (lazyRun (environment auxiliary) (sequenceFin fun index => disclosure (coordinates index)) state >>= fun middle =>
+        cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot (next middle.1) (cache, middle.2)) := by
+  induction n generalizing state with
+  | zero =>
+      simp only [sequenceFin, pure_bind, lazyRun_pure]
+  | succ n ih =>
+      rw [sequenceFin]
+      simp only [bind_assoc, pure_bind]
+      rw [cachedForcedRun_disclosure_bind, lazyRun_disclosure_bind, bind_assoc]
+      apply congrArg (cell (state.allowed (coordinates 0)) >>= ·)
+      funext value
+      rw [ih, lazyRun_bind, bind_assoc]
+      apply congrArg (_ >>= ·)
+      funext middle
+      rw [lazyRun_pure, pure_bind]
+
+theorem cachedForcedRun_completeRecord (record : PublicSigningRecord) (cache : QueryCache HashSpec)
+    (state : State Coordinate Digest PUnit) (auxiliary : QueryImpl Auxiliary ProbComp) :
+    cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+      (FtsGuessSigning.completeRecord record) (cache, state) =
+      (fun result => (result.1, (cache, result.2))) <$> lazyRun (environment auxiliary) (FtsGuessSigning.completeRecord record) state := by
+  obtain ⟨⟨plan, view⟩, trace⟩ := record
+  cases plan with
+  | none =>
+      simp only [FtsGuessSigning.completeRecord, cachedForcedRun_pure, lazyRun, SecretGuessObservation.runWith_pure, map_pure]
+  | some plan =>
+      cases view with
+      | none =>
+          simp only [FtsGuessSigning.completeRecord, cachedForcedRun_pure, lazyRun, SecretGuessObservation.runWith_pure, map_pure]
+      | some view =>
+          simp only [FtsGuessSigning.completeRecord]
+          rw [cachedForcedRun_disclosureSequence parameter root otsSecret labels inputs hencoding selections rows dummy slot _ _ cache state
+            auxiliary, lazyRun_bind, map_bind]
+          apply congrArg (_ >>= ·)
+          funext middle
+          rw [cachedForcedRun_pure, lazyRun_pure, map_pure]
+
+theorem cachedForcedRun_auxiliary_query (input : Auxiliary.Domain) (cache : QueryCache HashSpec)
+    (state : State Coordinate Digest PUnit) :
+    cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+      (liftM (World.query (.inl input))) (cache, state) =
+      (fun result => (result.1, (result.2, state))) <$>
+        cachedAuxiliary parameter root otsSecret labels inputs hencoding selections rows dummy input cache := by
+  rw [cachedForcedRun_query]
+  rfl
+
+theorem cachedForcedRun_completeRecord_mixture (record : PublicSigningRecord) (cache : QueryCache HashSpec)
+    (state : State Coordinate Digest PUnit) (ha : ∀ coordinate, (state.allowed coordinate).Nonempty)
+    (auxiliary : QueryImpl Auxiliary ProbComp) :
+    cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+      (FtsGuessSigning.completeRecord record) (cache, state) =
+      (complete state.allowed >>= fun secrets =>
+        pure (completePublicSigningRecord (fun index tree leaf => secrets (index, tree, leaf)) record,
+          (cache, FtsGuessSigning.completedState (environment auxiliary) secrets record state))) := by
+  rw [cachedForcedRun_completeRecord parameter root otsSecret labels inputs hencoding selections rows dummy slot record cache state
+    auxiliary, ← SecretGuessObservation.run_erasure (environment auxiliary) _ state ha, map_bind]
+  apply congrArg (complete state.allowed >>= ·)
+  funext secrets
+  rw [FtsGuessSigning.fixedRun_completeRecord, map_pure]
+
+/-- The cached signing law is the actual random-oracle digest loop from the current cache, completed with a secret table drawn from the current candidates, whose selected coordinates are then disclosed. -/
+theorem cachedForcedRun_signingProgram (message : Message) (cache : QueryCache HashSpec)
+    (state : State Coordinate Digest PUnit) (ha : ∀ coordinate, (state.allowed coordinate).Nonempty)
+    (hinputs : hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs)
+    (auxiliary : QueryImpl Auxiliary ProbComp) :
+    cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot (signingProgram message) (cache, state) =
+      (complete state.allowed >>= fun secrets =>
+        (fun result => (completePublicSigningRecord (fun index tree leaf => secrets (index, tree, leaf)) result.1,
+          (result.2, FtsGuessSigning.completedState (environment auxiliary) secrets result.1 state))) <$>
+          𝒟[(simulateQ romImpl (Prod.fst <$> ResidualByteFrontend.publicSigningWork parameter root (known otsSecret labels)
+            (referenceFamilyWords selections dummy) selections message)).run cache]) := by
+  rw [signingProgram, cachedForcedRun_bind, cachedForcedRun_auxiliary_query, bind_map_left, cachedAuxiliary, seedProgram,
+    cached_reference_signing_record parameter root otsSecret labels inputs hencoding selections rows dummy message cache hinputs]
+  simp only [cachedForcedRun_completeRecord_mixture parameter root otsSecret labels inputs hencoding selections rows dummy slot _ _ state ha
+    auxiliary]
+  rw [RetainedObservation.bind_comm]
+  apply congrArg (complete state.allowed >>= ·)
+  funext secrets
+  rw [map_eq_bind_pure_comp]
+  exact congrArg (_ >>= ·) (funext fun _ => rfl)
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessDeferredMessage.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessDeferredMessage.lean
new file mode 100644
index 000000000..405342afb
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessDeferredMessage.lean
@@ -0,0 +1,67 @@
+import SphincsSecurity.Proof.Forced.FtsGuessNearDeferred
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting UniformTableCompletion
+open FtsProbeSimulation (MessageHashInput)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+  publicDigestLoop canonicalGraphRoot canonicalGraphInput
+
+theorem message_not_probe (parameter : PublicParameter) (input : HashInput)
+    (hmessage : MessageHashInput parameter input) : FtsProbeSimulation.decodeProbe? parameter input = none := by
+  rw [FtsProbeSimulation.decodeProbe?_eq_none_iff]
+  obtain ⟨payload, rfl⟩ := hmessage
+  intro probe heq
+  have hdomain := (tweakableHashInput_injective parameter (by trivial) (by trivial) heq).1
+  exact HashDomain.noConfusion hdomain
+
+theorem knownEncodingCell_not_message (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (known : Labels) (input : inputs)
+    (hmessage : MessageHashInput parameter input.val) :
+    input ∉ Set.range (knownEncodingCell parameter inputs hencoding known) := by
+  rintro ⟨row, heq⟩
+  have hat : AtEncodingPosition parameter (knownEncodingCell parameter inputs hencoding known row).val row.1 := ⟨_, rfl⟩
+  rw [heq] at hat
+  exact ResidualByteFrontend.message_not_encoding parameter input.val hmessage row.1 hat
+
+theorem canonicalEncodingCell_not_message (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (labels : CanonicalGraphLabels) (input : inputs)
+    (hmessage : MessageHashInput parameter input.val) :
+    input ∉ Set.range (canonicalEncodingCell parameter inputs hencoding labels) := by
+  rintro ⟨row, heq⟩
+  have hat : AtEncodingPosition parameter (canonicalEncodingCell parameter inputs hencoding labels row).val row.1 := ⟨_, rfl⟩
+  rw [heq] at hat
+  exact ResidualByteFrontend.message_not_encoding parameter input.val hmessage row.1 hat
+
+theorem residualWorld_message (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (known : Labels) (rows : CanonicalEncodingRows)
+    (input : inputs) (hmessage : MessageHashInput parameter input.val) :
+    residualWorld parameter inputs hencoding known rows (.inr input.val) =
+      liftM ((SeedSpec inputs).query (.inr input)) := by
+  rw [residualWorld, residualProgram, dif_pos input.property,
+    dif_neg (knownEncodingCell_not_message parameter inputs hencoding known input hmessage)]
+
+theorem auxiliaryHashProgram_message (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+    (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+    (rows : CanonicalEncodingRows) (input : inputs) (hmessage : MessageHashInput parameter input.val) :
+    auxiliaryHashProgram parameter otsSecret labels inputs hencoding rows input.val =
+      liftM ((SeedSpec inputs).query (.inr input)) := by
+  have hd : decodePosition parameter input.val = none := by
+    obtain ⟨payload, heq⟩ := hmessage
+    rw [← heq]
+    exact decodePosition_message parameter payload
+  rw [auxiliaryHashProgram, message_not_probe parameter input.val hmessage, hd, residualProgram,
+    dif_pos input.property, dif_neg (canonicalEncodingCell_not_message parameter inputs hencoding labels input hmessage)]
+
+theorem referenceProgram_message (parameter : PublicParameter) (root : Digest)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+    (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+    (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (dummy : OtsReferenceWords)
+    (input : inputs) (hmessage : MessageHashInput parameter input.val) :
+    referenceProgram parameter root otsSecret labels inputs hencoding selections rows dummy (.inl (.inr input.val)) =
+      liftM ((SeedSpec inputs).query (.inr input)) :=
+  auxiliaryHashProgram_message parameter otsSecret labels inputs hencoding rows input hmessage
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessDeferredSeed.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessDeferredSeed.lean
new file mode 100644
index 000000000..5198b7752
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessDeferredSeed.lean
@@ -0,0 +1,96 @@
+import SphincsSecurity.Proof.Forced.FtsGuessAuxiliaryProgram
+import SphincsSecurity.Proof.Forced.SecretGuessForcedProgram
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec UniformTableCompletion
+open FtsGuessSigning (Coordinate)
+open SecretGuessObservation (State initialState forcedRun forcedProgram)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  publicDigestLoop canonicalGraphRoot canonicalGraphInput
+
+abbrev SecretSamplingSpec := (SPMF Bool →ₒ Bool) + (SPMF Digest →ₒ Digest)
+abbrev ForcedSeedAuxiliary := unifSpec + SecretSamplingSpec
+abbrev ForcedSeedSpec (inputs : Finset HashInput) := ForcedSeedAuxiliary + (inputs →ₒ HashOutput)
+
+noncomputable def forcedSeedAuxiliary : QueryImpl ForcedSeedAuxiliary SPMF
+  | .inl input => 𝒟[(liftM (unifSpec.query input) : ProbComp _)]
+  | .inr (.inl law) => law
+  | .inr (.inr law) => law
+
+noncomputable def seedLift (inputs : Finset HashInput) : QueryImpl (SeedSpec inputs) (OracleComp (ForcedSeedSpec inputs))
+  | .inl input => liftM ((ForcedSeedSpec inputs).query (.inl (.inl input)))
+  | .inr input => liftM ((ForcedSeedSpec inputs).query (.inr input))
+
+noncomputable def sampleForcedBool (inputs : Finset HashInput) (law : SPMF Bool) : OracleComp (ForcedSeedSpec inputs) Bool :=
+  liftM ((ForcedSeedSpec inputs).query (.inl (.inr (.inl law))))
+
+noncomputable def sampleForcedDigest (inputs : Finset HashInput) (law : SPMF Digest) : OracleComp (ForcedSeedSpec inputs) Digest :=
+  liftM ((ForcedSeedSpec inputs).query (.inl (.inr (.inr law))))
+
+theorem seedLift_fixed {Result : Type} (inputs : Finset HashInput) (seed : inputs → HashOutput)
+    (computation : OracleComp (SeedSpec inputs) Result) :
+    simulateQ (UniformTableObservation.fixedImpl forcedSeedAuxiliary seed) (simulateQ (seedLift inputs) computation) =
+      𝒟[simulateQ (seedAnswers inputs seed) computation] := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => simp only [simulateQ_pure, evalDist_pure]
+  | query_bind input next ih =>
+      simp only [simulateQ_bind, simulateQ_spec_query, evalDist_bind]
+      cases input <;> simp only [seedLift, seedAnswers, simulateQ_spec_query, UniformTableObservation.fixedImpl,
+        forcedSeedAuxiliary, evalDist_pure, pure_bind, ih]
+
+noncomputable def forcedSeedProgram (parameter : PublicParameter) (root : Digest)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+    (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+    (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (dummy : OtsReferenceWords)
+    (slot : Nat) (adversary : Adversary) : OracleComp (ForcedSeedSpec inputs) (Completed × State Coordinate Digest PUnit) :=
+  forcedProgram (fun input => simulateQ (seedLift inputs)
+    (referenceProgram parameter root otsSecret labels inputs hencoding selections rows dummy input))
+    (sampleForcedBool inputs) (sampleForcedDigest inputs) slot
+    (completedRun parameter root labels adversary) (initialState PUnit.unit)
+
+theorem forcedSeedProgram_fixed (parameter : PublicParameter) (root : Digest)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+    (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+    (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (seed : inputs → HashOutput)
+    (dummy : OtsReferenceWords) (slot : Nat) (adversary : Adversary) :
+    simulateQ (UniformTableObservation.fixedImpl forcedSeedAuxiliary seed)
+      (forcedSeedProgram parameter root otsSecret labels inputs hencoding selections rows dummy slot adversary) =
+        forcedRun (SecretGuessObservation.environment
+          (referenceAnswers parameter root otsSecret labels inputs hencoding ⟨selections, rows, seed⟩ dummy)) slot
+          (completedRun parameter root labels adversary) (initialState PUnit.unit) := by
+  apply SecretGuessObservation.simulateQ_forcedProgram
+  · intro input
+    rw [seedLift_fixed, referenceProgram_fixed]
+  · intro law
+    simp only [sampleForcedBool, simulateQ_spec_query, UniformTableObservation.fixedImpl, forcedSeedAuxiliary]
+  · intro law
+    simp only [sampleForcedDigest, simulateQ_spec_query, UniformTableObservation.fixedImpl, forcedSeedAuxiliary]
+
+noncomputable def deferredForcedRun (parameter : PublicParameter) (root : Digest)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+    (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+    (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (dummy : OtsReferenceWords)
+    (slot : Nat) (adversary : Adversary) : SPMF ((Completed × State Coordinate Digest PUnit) × (inputs → Finset HashOutput)) :=
+  UniformTableObservation.lazyRun forcedSeedAuxiliary
+    (forcedSeedProgram parameter root otsSecret labels inputs hencoding selections rows dummy slot adversary)
+    (fun _ => Finset.univ)
+
+theorem forcedRun_seed_marginal (parameter : PublicParameter) (root : Digest)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+    (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+    (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (dummy : OtsReferenceWords)
+    (slot : Nat) (adversary : Adversary) :
+    (𝒟[PMF.uniformOfFintype (inputs → HashOutput)] >>= fun seed =>
+      forcedRun (SecretGuessObservation.environment
+        (referenceAnswers parameter root otsSecret labels inputs hencoding ⟨selections, rows, seed⟩ dummy)) slot
+        (completedRun parameter root labels adversary) (initialState PUnit.unit)) =
+      Prod.fst <$> deferredForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot adversary := by
+  have h := UniformTableObservation.run_marginal forcedSeedAuxiliary
+    (forcedSeedProgram parameter root otsSecret labels inputs hencoding selections rows dummy slot adversary)
+    (fun _ => Finset.univ) (fun _ => Finset.univ_nonempty)
+  rw [complete_of_nonempty _ (fun _ => Finset.univ_nonempty), uniformTable_univ] at h
+  simpa only [forcedSeedProgram_fixed, deferredForcedRun] using h
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessEventTransfer.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessEventTransfer.lean
new file mode 100644
index 000000000..a6bd9d21a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessEventTransfer.lean
@@ -0,0 +1,117 @@
+import SphincsSecurity.Proof.Forced.FtsGuessPairBound
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec UniformTableCompletion
+open FtsGuessSigning (Coordinate)
+open SecretGuessObservation (State fixedRun lazyRun initialState)
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  frontierRoot maskOtsPrefixes frontierSigningRun boundaryEval referenceAnswers completedRun complete
+
+private theorem support_nonzero {Result : Type} (law : SPMF Result) (result : Result) (hr : result ∈ support law) :
+    law result ≠ 0 := by
+  simpa only [mem_support_iff, SPMF.probOutput_eq_apply] using hr
+
+theorem initialRun_posterior {Result : Type} (auxiliary : QueryImpl Auxiliary ProbComp)
+    (computation : OracleComp World Result) :
+    (complete (fun _ : Coordinate => (Finset.univ : Finset Digest)) >>= fun secrets =>
+      (fun value => (secrets, value)) <$> 𝒟[simulateQ (fixedAnswers auxiliary secrets) computation]) =
+      (lazyRun (SecretGuessObservation.environment auxiliary) computation (initialState PUnit.unit) >>= fun result =>
+        (fun secrets => (secrets, result.1)) <$> complete result.2.allowed) := by
+  have h := congrArg (Functor.map (fun result : (Coordinate → Digest) × Result × State Coordinate Digest PUnit =>
+    (result.1, result.2.1)))
+    (SecretGuessObservation.run_posterior (SecretGuessObservation.environment auxiliary) computation (initialState PUnit.unit))
+  simp only [map_bind, Functor.map_map] at h
+  rw [← h]
+  apply congrArg (complete (fun _ : Coordinate => (Finset.univ : Finset Digest)) >>= ·)
+  funext secrets
+  rw [← SecretGuessObservation.fixedRun_projection auxiliary secrets computation (initialState PUnit.unit), Functor.map_map]
+
+theorem initialEvent_le {Result : Type} (auxiliary : QueryImpl Auxiliary ProbComp)
+    (computation : OracleComp World Result) (event : (Coordinate → Digest) → Result → Prop)
+    (good : Result × State Coordinate Digest PUnit → Prop)
+    (hevent : ∀ result,
+      lazyRun (SecretGuessObservation.environment auxiliary) computation (initialState PUnit.unit) result ≠ 0 →
+      ∀ secrets, complete result.2.allowed secrets ≠ 0 → event secrets result.1 → good result) :
+    Pr[fun result => event result.1 result.2 |
+      complete (fun _ : Coordinate => (Finset.univ : Finset Digest)) >>= fun secrets =>
+        (fun value => (secrets, value)) <$> 𝒟[simulateQ (fixedAnswers auxiliary secrets) computation]] ≤
+      Pr[good | lazyRun (SecretGuessObservation.environment auxiliary) computation (initialState PUnit.unit)] := by
+  rw [initialRun_posterior]
+  apply probEvent_bind_le_probEvent
+  intro result hr hgood
+  rw [probEvent_map, probEvent_eq_zero_iff]
+  intro secrets hs he
+  exact hgood (hevent result
+    (support_nonzero (lazyRun (SecretGuessObservation.environment auxiliary) computation (initialState PUnit.unit)) result hr)
+    secrets (support_nonzero (complete result.2.allowed) secrets hs) he)
+
+def completedTwoGuesses (key : SecretKey) (f : QueryImpl HashSpec Id) (result : Completed) : Prop :=
+  ReferenceFtsCoverage.TwoGuesses key f result.1.1.1.2 (result.1.2 * result.2.2) result.1.1.1.1
+
+theorem lazy_reference_two_guesses (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary inputs) (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support)
+    (dummy : OtsReferenceWords) (adversary : Adversary) (result : Completed × State Coordinate Digest PUnit)
+    (hr : lazyRun
+      (SecretGuessObservation.environment (referenceAnswers key.parameter key.root key.otsSecret labels inputs hencoding auxiliary dummy))
+      (completedRun key.parameter key.root labels adversary) (initialState PUnit.unit) result ≠ 0)
+    (hsecrets : complete result.2.allowed (FtsGuessSigning.secretTable key.ftsSecret) ≠ 0)
+    (hevent : completedTwoGuesses key (programmedHash key.parameter key.otsSecret key.ftsSecret labels
+      (finiteHashAnswer ∅ inputs (canonicalReferenceResidual key.parameter inputs hencoding labels auxiliary.rows auxiliary.seed))) result.1) :
+    2 ≤ result.2.guesses.card := by
+  have tracking := lazy_reference_completedRun_tracking key inputs hencoding labels auxiliary hauxiliary dummy adversary
+    (initialState PUnit.unit) result hr hsecrets
+  exact tracking.two_guesses rfl _ hevent
+
+theorem initial_reference_two_witnesses (parameter : PublicParameter) (root : Digest)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary inputs) (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    Pr[fun result => completedTwoGuesses ⟨parameter, root, otsSecret, FtsGuessSigning.secretTable.symm result.1⟩
+      (programmedHash parameter otsSecret (FtsGuessSigning.secretTable.symm result.1) labels
+        (finiteHashAnswer ∅ inputs (canonicalReferenceResidual parameter inputs hencoding labels auxiliary.rows auxiliary.seed))) result.2 |
+      complete (fun _ : Coordinate => (Finset.univ : Finset Digest)) >>= fun secrets =>
+        (fun value => (secrets, value)) <$> 𝒟[simulateQ
+          (fixedAnswers (referenceAnswers parameter root otsSecret labels inputs hencoding auxiliary dummy) secrets)
+          (completedRun parameter root labels adversary)]] ≤
+      Pr[fun result => 2 ≤ result.2.guesses.card | lazyRun
+        (SecretGuessObservation.environment (referenceAnswers parameter root otsSecret labels inputs hencoding auxiliary dummy))
+        (completedRun parameter root labels adversary) (initialState PUnit.unit)] := by
+  apply initialEvent_le _ _ (fun secrets result => completedTwoGuesses
+    ⟨parameter, root, otsSecret, FtsGuessSigning.secretTable.symm secrets⟩
+    (programmedHash parameter otsSecret (FtsGuessSigning.secretTable.symm secrets) labels
+      (finiteHashAnswer ∅ inputs (canonicalReferenceResidual parameter inputs hencoding labels auxiliary.rows auxiliary.seed))) result)
+    (fun result => 2 ≤ result.2.guesses.card)
+  intro result hr secrets hs hevent
+  refine lazy_reference_two_guesses ⟨parameter, root, otsSecret, FtsGuessSigning.secretTable.symm secrets⟩
+    inputs hencoding labels auxiliary hauxiliary dummy adversary result ?_ ?_ ?_
+  · exact hr
+  · have htable : FtsGuessSigning.secretTable
+        (⟨parameter, root, otsSecret, FtsGuessSigning.secretTable.symm secrets⟩ : SecretKey).ftsSecret = secrets :=
+      Equiv.apply_symm_apply FtsGuessSigning.secretTable secrets
+    exact (congrArg (fun table => complete result.2.allowed table ≠ 0) htable).mpr hs
+  · exact hevent
+
+theorem initial_original_two_witnesses (dummy : OtsReferenceWords) (adversary : Adversary) (budget : Nat)
+    (hbudget : HasHashQueryBound scheme adversary budget) (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary (canonicalGraphGameInputs adversary))
+    (hauxiliary : auxiliary ∈ (referenceAuxiliarySample (canonicalGraphGameInputs adversary)).support) :
+    let inputs := canonicalGraphGameInputs adversary
+    let hencoding := canonicalEncodingInputs_subset_gameInputs adversary parameter
+    let residual := finiteHashAnswer ∅ inputs (canonicalReferenceResidual parameter inputs hencoding labels auxiliary.rows auxiliary.seed)
+    Pr[fun result => completedTwoGuesses
+      ⟨parameter, canonicalGraphRoot labels, otsSecret, FtsGuessSigning.secretTable.symm result.1⟩
+      (programmedHash parameter otsSecret (FtsGuessSigning.secretTable.symm result.1) labels residual) result.2 |
+      complete (fun _ : Coordinate => (Finset.univ : Finset Digest)) >>= fun secrets =>
+        (fun value => (secrets, value)) <$> 𝒟[simulateQ
+          (fixedAnswers (originalAnswers dummy adversary parameter otsSecret labels auxiliary) secrets)
+          (completedRun parameter (canonicalGraphRoot labels) labels adversary)]] ≤ pairRate budget := by
+  exact (initial_reference_two_witnesses parameter (canonicalGraphRoot labels) otsSecret
+    (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary parameter)
+    labels auxiliary hauxiliary dummy adversary).trans
+    (lazy_original_two_guesses dummy adversary budget hbudget parameter otsSecret labels auxiliary hauxiliary)
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessExceptionBounds.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessExceptionBounds.lean
new file mode 100644
index 000000000..c0086bec4
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessExceptionBounds.lean
@@ -0,0 +1,291 @@
+import SphincsSecurity.Proof.Forced.FtsGuessExceptionHistory
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec UniformTableCompletion OtsContactTrace ENNReal
+open FtsGuessSigning (Coordinate)
+open FtsProbeSimulation (MessageHashInput messageAnswers messageHashCharge)
+open SecretGuessObservation (State)
+open RetainedResidual (proposalOfSigningRecord proposalOfWorldResult nativeMessageCharge signingAnnotation)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  publicDigestLoop canonicalGraphRoot canonicalGraphInput hashInputs UniformTableCompletion.complete signDigestLoop
+  certificateCacheExceptionWeight
+
+variable (parameter : PublicParameter) (root : Digest)
+  (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+  (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+  (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (dummy : OtsReferenceWords) (slot : Nat)
+  (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+/-! ### Runs are probability laws -/
+
+theorem monitoredRun_bind_const {Result Other : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result) (state : MonitoredState)
+    (hvalid : Valid state) (after : SPMF Other) :
+    (monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter computation state >>=
+      fun _ => after) = after := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => rw [monitoredRun_pure, pure_bind]
+  | query_bind input next ih =>
+      rw [monitoredRun_query_bind, bind_assoc]
+      rw [RetainedObservation.bind_congr _ _ (fun _ => after) (fun step hstep => by
+        rw [bind_map_left]
+        exact ih step.1.1.1 step.2 (monitoredStep_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+          required stopAfter input state hvalid step hstep))]
+      exact monitoredStep_bind_const parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        input state hvalid after
+
+theorem tsum_monitoredRun_eq_one {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result) (state : MonitoredState)
+    (hvalid : Valid state) :
+    (∑' result, Pr[= result | monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      computation state]) = 1 := by
+  have h := congrArg (fun law : SPMF Unit => Pr[= () | law])
+    (monitoredRun_bind_const parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter computation
+      state hvalid (pure ()))
+  simpa only [probOutput_bind_eq_tsum, probOutput_pure_self, mul_one] using h
+
+theorem tsum_monitoredWorldRun_eq_one {Result : Type} (computation : OracleComp OracleWorld Result) (state : MonitoredState)
+    (hvalid : Valid state) :
+    (∑' result, Pr[= result | monitoredWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+      stopAfter computation state]) = 1 := by
+  have h := congrArg (fun law : SPMF Unit => Pr[= () | law])
+    (monitoredWorldRun_bind_const parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      computation state hvalid (pure ()))
+  simpa only [probOutput_bind_eq_tsum, probOutput_pure_self, mul_one] using h
+
+/-! ### Message charges are paid by hash calls -/
+
+theorem nativeMessageCharge_le_worldStep (input : OracleWorld.Domain) (state : MonitoredState) (hvalid : Valid state)
+    (hinputs : hashInputs (liftM (OracleWorld.query input)) ⊆ inputs) :
+    nativeMessageCharge (monitorKey parameter root) (.inl input) (monitorView state) ≤
+      ∑' result, Pr[= result | cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+        (worldProgram parameter labels input) state.1] * ((signingBoundaryTrace parameter input result.1).hashCalls : ENNReal) := by
+  cases input with
+  | inl sample =>
+      simp only [nativeMessageCharge, hashQueryCharge, Sum.elim_inl]
+      exact zero_le
+  | inr hash =>
+      have hone : ∀ result : OracleWorld.Range (.inr hash) × CachedState,
+          ((signingBoundaryTrace parameter (.inr hash) result.1).hashCalls : ENNReal) = 1 := by
+        intro result
+        simp only [signingBoundaryTrace, SigningBoundaryTrace.hashCalls_of, Nat.cast_one]
+      simp only [hone, mul_one]
+      rw [tsum_cachedForcedRun_eq_one parameter root otsSecret labels inputs hencoding selections rows dummy slot
+        (worldProgram parameter labels (.inr hash)) state.1 hvalid]
+      simp only [nativeMessageCharge, hashQueryCharge, Sum.elim_inr, messageHashCharge, monitorView]
+      split_ifs <;> norm_num
+
+theorem nativeMessageCharge_le_forcedSigning (message : Message) (state : MonitoredState) (hvalid : Valid state)
+    (hinputs : hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs) :
+    nativeMessageCharge (monitorKey parameter root) (.inr message) (monitorView state) ≤
+      ∑' result, Pr[= result | forcedSigning parameter root otsSecret labels inputs hencoding selections rows dummy slot message state] *
+        (result.1.2.hashCalls : ENNReal) := by
+  have hwork := RetainedResidual.expected_publicSigningWork_messageCalls (monitorKey parameter root) (known otsSecret labels)
+    (referenceFamilyWords selections dummy) selections message state.1.1
+  have hparameter : (monitorKey parameter root).parameter = parameter := rfl
+  have hroot : (monitorKey parameter root).root = root := rfl
+  rw [hparameter, hroot] at hwork
+  rw [forcedSigning, cachedForcedRun_signingProgram' parameter root otsSecret labels inputs hencoding selections rows dummy slot message state.1
+    hvalid hinputs (referenceAnswers parameter root otsSecret labels inputs hencoding ⟨selections, rows, fun _ => 0⟩ dummy),
+    tsum_probOutput_bind_mul]
+  simp only [tsum_probOutput_map_mul, completePublicSigningRecord_trace]
+  rw [simulateQ_map, StateT.run_map, evalDist_map, tsum_probOutput_map_mul, tsum_probOutput_evalDist, ENNReal.tsum_mul_right]
+  have hmass : (∑' secrets, Pr[= secrets | complete state.1.2.allowed]) = 1 := by
+    rw [complete_of_nonempty _ hvalid]
+    simp only [SPMF.probOutput_eq_apply, SPMF.liftM_apply, PMF.tsum_coe]
+  rw [hmass, one_mul]
+  change digestAttemptExpectation digestAttemptLimit (monitorKey parameter root) message state.1.1 ≤ _
+  rw [← hwork]
+  apply ENNReal.tsum_le_tsum
+  intro result
+  apply mul_le_mul' le_rfl
+  exact Nat.cast_le.mpr (List.length_filterMap_le _ _)
+
+theorem nativeMessageCharge_le_monitoredStep (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState) (hvalid : Valid state)
+    (hworld : ∀ world, input = .inl world → hashInputs (liftM (OracleWorld.query world)) ⊆ inputs)
+    (hsign : ∀ message, input = .inr message → hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs) :
+    nativeMessageCharge (monitorKey parameter root) input (monitorView state) ≤
+      ∑' result, Pr[= result | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter input state] * (result.1.1.2.hashCalls : ENNReal) := by
+  cases input with
+  | inl input =>
+      rw [monitoredStep, monitoredWorldStep, tsum_probOutput_map_mul]
+      exact nativeMessageCharge_le_worldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot input state hvalid
+        (hworld input rfl)
+  | inr message =>
+      rw [monitoredStep, monitoredSignStep_eq, tsum_probOutput_bind_mul]
+      simp only [tsum_probOutput_map_mul]
+      have hstep := nativeMessageCharge_le_forcedSigning parameter root otsSecret labels inputs hencoding selections rows dummy slot message state
+        hvalid (hsign message rfl)
+      calc
+        _ = ∑' annotation, Pr[= annotation | (liftM (signingAnnotation (monitorKey parameter root) budget message (monitorView state)) : SPMF _)] *
+            nativeMessageCharge (monitorKey parameter root) (.inr message) (monitorView state) := by
+          rw [ENNReal.tsum_mul_right]
+          simp only [SPMF.probOutput_eq_apply, SPMF.liftM_apply, PMF.tsum_coe, one_mul]
+        _ ≤ _ := ENNReal.tsum_le_tsum fun _ => mul_le_mul' le_rfl hstep
+
+variable (hauxiliary : ∀ seed : inputs → HashOutput,
+  (⟨selections, rows, seed⟩ : ReferenceAuxiliary inputs) ∈ (referenceAuxiliarySample inputs).support)
+
+include hauxiliary in
+theorem expectedMonitoredPayment_le_hashCalls (computation : OracleComp (OracleWorld + SigningSpec) Forgery) (state : MonitoredState)
+    (hvalid : Valid state) (hcovered : CoveredRun parameter root otsSecret inputs computation state) :
+    expectedMonitoredPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      (nativeMessageCharge (monitorKey parameter root)) computation state ≤
+      ∑' result, Pr[= result | monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        computation state] * (result.1.1.2.hashCalls : ENNReal) := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [expectedMonitoredPayment, construct_pure, zero_le]
+  | query_bind input next ih =>
+      rw [expectedMonitoredPayment_query_bind, monitoredRun_query_bind, tsum_probOutput_bind_mul]
+      calc
+        _ ≤ (∑' step, Pr[= step | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+              stopAfter input state] * (step.1.1.2.hashCalls : ENNReal)) +
+            ∑' step, Pr[= step | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+              stopAfter input state] *
+              ∑' tail, Pr[= tail | monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+                stopAfter (next step.1.1.1) step.2] * (tail.1.1.2.hashCalls : ENNReal) := by
+          apply add_le_add (nativeMessageCharge_le_monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+            required stopAfter input state hvalid
+            (fun world heq => by subst heq; exact covered_world_inputs parameter root otsSecret inputs world next state hvalid hcovered)
+            (covered_step_digest parameter root otsSecret inputs input next state hvalid hcovered))
+          apply ENNReal.tsum_le_tsum
+          intro step
+          by_cases hs : Pr[= step | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+              stopAfter input state] = 0
+          · simp only [hs, zero_mul, le_refl]
+          · rw [SPMF.probOutput_eq_apply] at hs
+            exact mul_le_mul' le_rfl (ih step.1.1.1 step.2
+              (monitoredStep_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input
+                state hvalid step hs)
+              (covered_step_next parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter hauxiliary
+                input next state hvalid hcovered step hs))
+        _ = _ := by
+          rw [← ENNReal.tsum_add]
+          apply tsum_congr
+          intro step
+          by_cases hs : Pr[= step | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+              stopAfter input state] = 0
+          · simp only [hs, zero_mul, add_zero]
+          · rw [SPMF.probOutput_eq_apply] at hs
+            have hvalid' := monitoredStep_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+              stopAfter input state hvalid step hs
+            rw [tsum_probOutput_map_mul, ← mul_add]
+            apply congrArg (_ * ·)
+            simp only [combineStep, SigningBoundaryTrace.hashCalls_mul, Nat.cast_add, mul_add, ENNReal.tsum_add, ENNReal.tsum_mul_right,
+              tsum_monitoredRun_eq_one parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+                (next step.1.1.1) step.2 hvalid', one_mul]
+
+theorem expectedWorldPayment_le_hashCalls {Result : Type} (computation : OracleComp OracleWorld Result) (state : MonitoredState)
+    (hvalid : Valid state) (hinputs : hashInputs computation ⊆ inputs) :
+    expectedWorldPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      (nativeMessageCharge (monitorKey parameter root)) computation state ≤
+      ∑' result, Pr[= result | monitoredWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter computation state] * (result.1.1.2.hashCalls : ENNReal) := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [expectedWorldPayment, construct_pure, zero_le]
+  | query_bind input next ih =>
+      rw [expectedWorldPayment_query_bind, monitoredWorldRun_query_bind, tsum_probOutput_bind_mul]
+      calc
+        _ ≤ (∑' step, Pr[= step | monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+              stopAfter input state] * (step.1.1.2.hashCalls : ENNReal)) +
+            ∑' step, Pr[= step | monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+              stopAfter input state] *
+              ∑' tail, Pr[= tail | monitoredWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+                stopAfter (next step.1.1.1) step.2] * (tail.1.1.2.hashCalls : ENNReal) := by
+          refine add_le_add ?_ ?_
+          · rw [← monitoredStep_inl]
+            exact nativeMessageCharge_le_monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+              stopAfter (.inl input) state hvalid (fun world heq => by cases heq; exact (hashInputs_world_query input next).trans hinputs)
+              (fun message heq => by cases heq)
+          · apply ENNReal.tsum_le_tsum
+            intro step
+            by_cases hs : Pr[= step | monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+                required stopAfter input state] = 0
+            · simp only [hs, zero_mul, le_refl]
+            · rw [SPMF.probOutput_eq_apply] at hs
+              exact mul_le_mul' le_rfl (ih step.1.1.1 step.2
+                (monitoredStep_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+                  (.inl input) state hvalid step hs) ((hashInputs_world_next input next step.1.1.1).trans hinputs))
+        _ = _ := by
+          rw [← ENNReal.tsum_add]
+          apply tsum_congr
+          intro step
+          by_cases hs : Pr[= step | monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+              required stopAfter input state] = 0
+          · simp only [hs, zero_mul, add_zero]
+          · rw [SPMF.probOutput_eq_apply] at hs
+            have hvalid' := monitoredStep_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+              stopAfter (.inl input) state hvalid step hs
+            rw [tsum_probOutput_map_mul, ← mul_add]
+            apply congrArg (_ * ·)
+            simp only [SigningBoundaryTrace.hashCalls_mul, Nat.cast_add, mul_add, ENNReal.tsum_add, ENNReal.tsum_mul_right,
+              tsum_monitoredWorldRun_eq_one parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+                (next step.1.1.1) step.2 hvalid', one_mul]
+
+theorem expectedMonitoredPayment_mul (charge : (OracleWorld + SigningSpec).Domain → CertificateMonitorState → ENNReal) (rate : ENNReal)
+    (computation : OracleComp (OracleWorld + SigningSpec) Forgery) (state : MonitoredState) :
+    expectedMonitoredPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      (fun input current => charge input current * rate) computation state =
+      expectedMonitoredPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter charge
+        computation state * rate := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => exact (zero_mul _).symm
+  | query_bind input next ih =>
+      rw [expectedMonitoredPayment_query_bind, expectedMonitoredPayment_query_bind, add_mul, ← ENNReal.tsum_mul_right]
+      congr 1
+      apply tsum_congr
+      intro result
+      rw [ih result.1.1.1 result.2, mul_assoc]
+
+include hauxiliary in
+theorem expectedCompletedPayment_le_work (adversary : Adversary) (state : MonitoredState) (hvalid : Valid state)
+    (hcovered : CoveredRun parameter root otsSecret inputs (adversary.main ⟨root, parameter⟩) state) :
+    expectedMonitoredPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        (nativeMessageCharge (monitorKey parameter root)) (adversary.main ⟨root, parameter⟩) state +
+      ∑' before, Pr[= before | monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        (adversary.main ⟨root, parameter⟩) state] *
+        expectedWorldPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          (nativeMessageCharge (monitorKey parameter root)) (verifyComputation parameter root before.1.1.1.1) before.2 ≤
+      ∑' result, Pr[= result | monitoredCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter adversary state] * (completedWork result.1 : ENNReal) := by
+  rw [monitoredCompletedRun_eq, tsum_probOutput_bind_mul]
+  calc
+    _ ≤ (∑' before, Pr[= before | monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter (adversary.main ⟨root, parameter⟩) state] * (before.1.1.2.hashCalls : ENNReal)) +
+        ∑' before, Pr[= before | monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter (adversary.main ⟨root, parameter⟩) state] *
+          ∑' checked, Pr[= checked | monitoredWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+            stopAfter (verifyComputation parameter root before.1.1.1.1) before.2] * (checked.1.1.2.hashCalls : ENNReal) := by
+      apply add_le_add (expectedMonitoredPayment_le_hashCalls parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+        required stopAfter hauxiliary (adversary.main ⟨root, parameter⟩) state hvalid hcovered)
+      apply ENNReal.tsum_le_tsum
+      intro before
+      by_cases hb : Pr[= before | monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter (adversary.main ⟨root, parameter⟩) state] = 0
+      · simp only [hb, zero_mul, le_refl]
+      · rw [SPMF.probOutput_eq_apply] at hb
+        have hvalid' := monitoredRun_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          (adversary.main ⟨root, parameter⟩) state hvalid before hb
+        have hfinal := monitoredRun_covered parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          hauxiliary (adversary.main ⟨root, parameter⟩) state hvalid hcovered before hb
+        exact mul_le_mul' le_rfl (expectedWorldPayment_le_hashCalls parameter root otsSecret labels inputs hencoding selections rows dummy slot
+          budget required stopAfter (verifyComputation parameter root before.1.1.1.1) before.2 hvalid'
+          (covered_pure parameter root otsSecret inputs before.1.1.1.1 before.2 hvalid' hfinal))
+    _ = _ := by
+      rw [← ENNReal.tsum_add]
+      apply tsum_congr
+      intro before
+      by_cases hb : Pr[= before | monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter (adversary.main ⟨root, parameter⟩) state] = 0
+      · simp only [hb, zero_mul, add_zero]
+      · rw [SPMF.probOutput_eq_apply] at hb
+        have hvalid' := monitoredRun_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          (adversary.main ⟨root, parameter⟩) state hvalid before hb
+        rw [tsum_probOutput_map_mul, ← mul_add]
+        apply congrArg (_ * ·)
+        simp only [completedWork, Nat.cast_add, mul_add, ENNReal.tsum_add, ENNReal.tsum_mul_right,
+          tsum_monitoredWorldRun_eq_one parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+            (verifyComputation parameter root before.1.1.1.1) before.2 hvalid', one_mul]
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessExceptionClassification.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessExceptionClassification.lean
new file mode 100644
index 000000000..ac3ed4dc8
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessExceptionClassification.lean
@@ -0,0 +1,298 @@
+import SphincsSecurity.Proof.Forced.FtsGuessExceptionWeights
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec UniformTableCompletion OtsContactTrace ENNReal
+open FtsGuessSigning (Coordinate)
+open FtsProbeSimulation (MessageHashInput messageAnswers)
+open SecretGuessObservation (State)
+open RetainedResidual (proposalOfSigningRecord proposalOfWorldResult proposalStop)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  publicDigestLoop canonicalGraphRoot canonicalGraphInput hashInputs UniformTableCompletion.complete signDigestLoop
+  certificateCacheExceptionWeight
+
+variable (parameter : PublicParameter) (root : Digest)
+  (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+  (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+  (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (dummy : OtsReferenceWords) (slot : Nat)
+  (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+/-! ### Step records and macro costs -/
+
+theorem monitoredStep_update (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState) (result : AdversaryStep input × MonitoredState)
+    (hresult : monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state
+      result ≠ 0) :
+    ∃ (length : Nat) (record : ProposalExecutionRecord input),
+      result.2.2 = certificateMonitorUpdate (monitorKey parameter root) budget required stopAfter input (monitorView state) length record ∧
+        record.cache = result.2.1.1 ∧ record.trace = result.1.1.2 ∧ record.output = result.1.1.1 := by
+  cases input with
+  | inl input =>
+      rw [monitoredStep, monitoredWorldStep] at hresult
+      obtain ⟨raw, _, rfl⟩ := map_nonzero_source' _ _ _ hresult
+      exact ⟨0, proposalOfWorldResult parameter input (raw.1, raw.2.1), rfl, rfl, rfl, rfl⟩
+  | inr message =>
+      rw [monitoredStep, monitoredSignStep_eq, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨annotation, _, hresult⟩ := hresult
+      obtain ⟨raw, _, rfl⟩ := map_nonzero_source' _ _ _ hresult
+      exact ⟨annotation.1, proposalOfSigningRecord message raw.1 raw.2.1 (raw.1.1.2.elim annotation.2 Prod.fst), rfl, rfl, rfl, rfl⟩
+
+theorem monitoredStep_macro (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState) (hvalid : Valid state)
+    (hsign : ∀ message, input = .inr message → hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs)
+    (result : AdversaryStep input × MonitoredState)
+    (hresult : monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state
+      result ≠ 0) : signingMacroHashCost input ≤ result.1.1.2.hashCalls := by
+  cases input with
+  | inl input =>
+      rw [monitoredStep, monitoredWorldStep] at hresult
+      obtain ⟨raw, _, rfl⟩ := map_nonzero_source' _ _ _ hresult
+      cases input with
+      | inl sample => exact Nat.zero_le _
+      | inr hash =>
+          change 1 ≤ (signingBoundaryTrace parameter (.inr hash) raw.1).hashCalls
+          simp only [signingBoundaryTrace, SigningBoundaryTrace.hashCalls_of, le_refl]
+  | inr message =>
+      rw [monitoredStep, monitoredSignStep_eq, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨annotation, _, hresult⟩ := hresult
+      obtain ⟨raw, hraw, rfl⟩ := map_nonzero_source' _ _ _ hresult
+      obtain ⟨source, hsource, htrace, _⟩ := forcedSigning_source parameter root otsSecret labels inputs hencoding selections rows dummy slot
+        message state hvalid (hsign message rfl) raw hraw
+      have hmin := publicSigningWork_hashCalls_min' parameter root (monitorKey parameter root) rfl rfl (known otsSecret labels)
+        (referenceFamilyWords selections dummy) selections message state.1.1 source hsource
+      change 1024 ≤ raw.1.2.hashCalls
+      rw [htrace]
+      exact (show 1024 ≤ 28504 by decide).trans hmin
+
+/-! ### Consistency of an unstopped monitor with its cache -/
+
+def Consistent (state : MonitoredState) : Prop :=
+  QueryCache.enncard state.1.1 ≤ state.2.spent ∧ SigningDigestsCached parameter state.1.1 root state.2.log
+
+private theorem update_stopped_eq (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState) (length : Nat)
+    (record : ProposalExecutionRecord input) (hactive : CertificateMonitorActive (monitorKey parameter root) budget input state)
+    (hready : CertificateMonitorReady (monitorKey parameter root) budget
+      (record.cache, certificateMonitorUpdate (monitorKey parameter root) budget required stopAfter input state length record)) :
+    (certificateMonitorUpdate (monitorKey parameter root) budget required stopAfter input state length record).stopped =
+      stopAfter input state length record := by
+  unfold certificateMonitorUpdate at hready ⊢
+  rw [if_pos hactive] at hready ⊢
+  simp only [CertificateMonitorReady] at hready ⊢
+  simp only [hready, and_self, not_true_eq_false, decide_false, Bool.or_false]
+
+private theorem update_log_of_active (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState) (length : Nat)
+    (record : ProposalExecutionRecord input) (hactive : CertificateMonitorActive (monitorKey parameter root) budget input state) :
+    (certificateMonitorUpdate (monitorKey parameter root) budget required stopAfter input state length record).log =
+      state.2.log ++ signingLogFragment input record.output := by
+  rw [certificateMonitorUpdate, if_pos hactive]
+  rfl
+
+theorem exceptionStep_unstopped (input : (OracleWorld + SigningSpec).Domain) (state : ExceptionState) (hvalid : Valid state.1)
+    (hworld : ∀ world, input = .inl world → hashInputs (liftM (OracleWorld.query world)) ⊆ inputs)
+    (hsign : ∀ message, input = .inr message → hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs)
+    (hcons : Consistent parameter root state.1) (halive : state.1.2.stopped = false) (hbudget : budget ≤ 2 ^ 127)
+    (result : AdversaryStep input × ExceptionState)
+    (hresult : exceptionStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+      (proposalStop (fun _ _ _ _ => false)) input state result ≠ 0)
+    (hcost : state.1.2.spent + result.1.1.2.hashCalls ≤ budget)
+    (hlog : state.1.2.log.length + (signingLogFragment input result.1.1.1).length ≤ signatureLimit)
+    (hclean : state.2 = (false, false)) (hcleanAfter : result.2.2 = (false, false)) :
+    result.2.1.2.stopped = false ∧ Consistent parameter root result.2.1 := by
+  obtain ⟨hmon, hupdate⟩ := exceptionStep_support parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+    (proposalStop (fun _ _ _ _ => false)) input state result hresult
+  rw [hupdate, hclean] at hcleanAfter
+  simp only [exceptionUpdate, Prod.mk.injEq, Bool.false_or, Bool.or_eq_false_iff, decide_eq_false_iff_not] at hcleanAfter
+  obtain ⟨⟨hbefore, hafter⟩, hprefix⟩ := hcleanAfter
+  have haccount := monitoredStep_account parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+    (proposalStop (fun _ _ _ _ => false)) input state.1 hvalid hworld hsign (result.1, result.2.1) hmon
+  have hmacro := monitoredStep_macro parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+    (proposalStop (fun _ _ _ _ => false)) input state.1 hvalid hsign (result.1, result.2.1) hmon
+  change signingMacroHashCost input ≤ result.1.1.2.hashCalls at hmacro
+  obtain ⟨length, record, hmonitor, hcache, htrace, houtput⟩ := monitoredStep_update parameter root otsSecret labels inputs hencoding selections
+    rows dummy slot budget required (proposalStop (fun _ _ _ _ => false)) input state.1 (result.1, result.2.1) hmon
+  change result.2.1.2 = _ at hmonitor
+  change record.cache = result.2.1.1.1 at hcache
+  change record.trace = result.1.1.2 at htrace
+  change record.output = result.1.1.1 at houtput
+  have hspentLe : state.1.2.spent ≤ budget := by omega
+  have hactive : CertificateMonitorActive (monitorKey parameter root) budget input (monitorView state.1) := by
+    refine ⟨halive, ⟨hcons.2, ?_, hspentLe⟩, ?_, ?_⟩
+    · exact proposalCacheBound_of_no_cache_exception (monitorKey parameter root) state.1.1.1 (Finite.of_enncard_le hcons.1) state.1.2.spent
+        (by omega) hcons.1 hbefore
+    · cases input with
+      | inl input =>
+          change state.1.2.log.length ≤ signatureLimit
+          simpa only [signingLogFragment, List.length_nil, Nat.add_zero] using hlog
+      | inr message =>
+          change state.1.2.log.length < signatureLimit
+          simp only [signingLogFragment, List.length_singleton] at hlog
+          omega
+    · change signingMacroHashCost input ≤ budget - state.1.2.spent
+      omega
+  have hnewSpent : (certificateMonitorUpdate (monitorKey parameter root) budget required (proposalStop (fun _ _ _ _ => false)) input
+      (monitorView state.1) length record).spent = state.1.2.spent + result.1.1.2.hashCalls := by
+    rw [certificateMonitorUpdate_spent (monitorKey parameter root) budget required _ input (monitorView state.1) length record hactive, htrace]
+    rfl
+  have hnewLog : (certificateMonitorUpdate (monitorKey parameter root) budget required (proposalStop (fun _ _ _ _ => false)) input
+      (monitorView state.1) length record).log = state.1.2.log ++ signingLogFragment input result.1.1.1 := by
+    rw [update_log_of_active parameter root budget required _ input (monitorView state.1) length record hactive, houtput]
+    rfl
+  have hready : CertificateMonitorReady (monitorKey parameter root) budget
+      (record.cache, certificateMonitorUpdate (monitorKey parameter root) budget required (proposalStop (fun _ _ _ _ => false)) input
+        (monitorView state.1) length record) := by
+    refine ⟨?_, ?_, ?_⟩
+    · change SigningDigestsCached parameter record.cache root (certificateMonitorUpdate (monitorKey parameter root) budget required
+        (proposalStop (fun _ _ _ _ => false)) input (monitorView state.1) length record).log
+      rw [hnewLog, hcache]
+      exact haccount.digests state.1.2.log hcons.2
+    · change ProposalCacheBound (monitorKey parameter root) record.cache (certificateMonitorUpdate (monitorKey parameter root) budget required
+        (proposalStop (fun _ _ _ _ => false)) input (monitorView state.1) length record).spent
+      rw [hnewSpent, hcache]
+      have hcard : QueryCache.enncard result.2.1.1.1 ≤ ((state.1.2.spent + result.1.1.2.hashCalls : Nat) : ENNReal) := by
+        rw [Nat.cast_add]
+        exact haccount.enncard.trans (add_le_add hcons.1 le_rfl)
+      exact proposalCacheBound_of_no_cache_exception (monitorKey parameter root) _ (Finite.of_enncard_le hcard) _ (by omega) hcard hafter
+    · change (certificateMonitorUpdate (monitorKey parameter root) budget required (proposalStop (fun _ _ _ _ => false)) input
+        (monitorView state.1) length record).spent ≤ budget
+      rw [hnewSpent]
+      exact hcost
+  have hstop := update_stopped_eq parameter root budget required (proposalStop (fun _ _ _ _ => false)) input (monitorView state.1) length record
+    hactive hready
+  have hprefixStop := proposalPrefixStop_eq_after_exception (monitorKey parameter root) budget required (proposalStop (fun _ _ _ _ => false))
+    input (monitorView state.1) length record hactive
+  rw [← hmonitor] at hstop hprefixStop
+  have hunstopped : result.2.1.2.stopped = false := by
+    rw [hstop]
+    simp only [proposalStop, Bool.or_false, hprefixStop, decide_eq_false_iff_not]
+    exact hprefix
+  refine ⟨hunstopped, ?_, ?_⟩
+  · rw [haccount.spent hunstopped]
+    change QueryCache.enncard result.2.1.1.1 ≤ ((state.1.2.spent + result.1.1.2.hashCalls : Nat) : ENNReal)
+    rw [Nat.cast_add]
+    exact haccount.enncard.trans (add_le_add hcons.1 le_rfl)
+  · rw [haccount.log hunstopped]
+    exact haccount.digests state.1.2.log hcons.2
+
+variable (hauxiliary : ∀ seed : inputs → HashOutput,
+  (⟨selections, rows, seed⟩ : ReferenceAuxiliary inputs) ∈ (referenceAuxiliarySample inputs).support)
+
+include hauxiliary in
+theorem exceptionRun_unstopped (computation : OracleComp (OracleWorld + SigningSpec) Forgery) (state : ExceptionState) (hvalid : Valid state.1)
+    (hcovered : CoveredRun parameter root otsSecret inputs computation state.1) (hcons : Consistent parameter root state.1)
+    (halive : state.1.2.stopped = false) (hbudget : budget ≤ 2 ^ 127) (result : AdversaryTrace × ExceptionState)
+    (hresult : exceptionRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+      (proposalStop (fun _ _ _ _ => false)) computation state result ≠ 0)
+    (hcost : state.1.2.spent + result.1.1.2.hashCalls ≤ budget) (hlog : state.1.2.log.length + result.1.1.1.2.length ≤ signatureLimit)
+    (hclean : result.2.2 = (false, false)) : result.2.1.2.stopped = false ∧ Consistent parameter root result.2.1 := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      rw [exceptionRun_pure] at hresult
+      simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact ⟨halive, hcons⟩
+  | query_bind input next ih =>
+      have hcleanState := exceptionRun_clean parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        (proposalStop (fun _ _ _ _ => false)) (liftM ((OracleWorld + SigningSpec).query input) >>= next) state result hresult hclean
+      rw [exceptionRun_query_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨step, hstep, hresult⟩ := hresult
+      obtain ⟨tail, htail, rfl⟩ := map_nonzero_source' _ _ _ hresult
+      have hcleanStep := exceptionRun_clean parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        (proposalStop (fun _ _ _ _ => false)) (next step.1.1.1) step.2 tail htail hclean
+      have hmon := (exceptionStep_support parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        (proposalStop (fun _ _ _ _ => false)) input state step hstep).1
+      simp only [combineStep, SigningBoundaryTrace.hashCalls_mul, List.length_append] at hcost hlog
+      have hworld : ∀ world, input = .inl world → hashInputs (liftM (OracleWorld.query world)) ⊆ inputs :=
+        fun world heq => by subst heq; exact covered_world_inputs parameter root otsSecret inputs world next state.1 hvalid hcovered
+      have hsign := covered_step_digest parameter root otsSecret inputs input next state.1 hvalid hcovered
+      obtain ⟨hstepAlive, hstepCons⟩ := exceptionStep_unstopped parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+        required input state hvalid hworld hsign hcons halive hbudget step hstep (by omega) (by omega) hcleanState hcleanStep
+      have haccount := monitoredStep_account parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        (proposalStop (fun _ _ _ _ => false)) input state.1 hvalid hworld hsign (step.1, step.2.1) hmon
+      have hspent := haccount.spent hstepAlive
+      have hlogStep := haccount.log hstepAlive
+      change step.2.1.2.spent = state.1.2.spent + step.1.1.2.hashCalls at hspent
+      change step.2.1.2.log = state.1.2.log ++ signingLogFragment input step.1.1.1 at hlogStep
+      exact ih step.1.1.1 step.2
+        (monitoredStep_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          (proposalStop (fun _ _ _ _ => false)) input state.1 hvalid _ hmon)
+        (covered_step_next parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          (proposalStop (fun _ _ _ _ => false)) hauxiliary input next state.1 hvalid hcovered _ hmon)
+        hstepCons hstepAlive tail htail (by rw [hspent]; omega) (by rw [hlogStep, List.length_append]; omega) hclean
+
+theorem exceptionWorldRun_unstopped {Result : Type} (computation : OracleComp OracleWorld Result) (state : ExceptionState)
+    (hvalid : Valid state.1) (hinputs : hashInputs computation ⊆ inputs) (hcons : Consistent parameter root state.1)
+    (halive : state.1.2.stopped = false) (hbudget : budget ≤ 2 ^ 127) (result : ((Result × SigningBoundaryTrace) × Trace) × ExceptionState)
+    (hresult : exceptionWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+      (proposalStop (fun _ _ _ _ => false)) computation state result ≠ 0)
+    (hcost : state.1.2.spent + result.1.1.2.hashCalls ≤ budget) (hlog : state.1.2.log.length ≤ signatureLimit)
+    (hclean : result.2.2 = (false, false)) : result.2.1.2.stopped = false ∧ Consistent parameter root result.2.1 := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      rw [exceptionWorldRun_pure] at hresult
+      simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact ⟨halive, hcons⟩
+  | query_bind input next ih =>
+      have hcleanState := exceptionWorldRun_clean parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        (proposalStop (fun _ _ _ _ => false)) (liftM (OracleWorld.query input) >>= next) state result hresult hclean
+      rw [exceptionWorldRun_query_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨step, hstep, hresult⟩ := hresult
+      obtain ⟨tail, htail, rfl⟩ := map_nonzero_source' _ _ _ hresult
+      have hcleanStep := exceptionWorldRun_clean parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        (proposalStop (fun _ _ _ _ => false)) (next step.1.1.1) step.2 tail htail hclean
+      have hmon := (exceptionStep_support parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        (proposalStop (fun _ _ _ _ => false)) (.inl input) state step hstep).1
+      simp only [SigningBoundaryTrace.hashCalls_mul] at hcost
+      have hworld : ∀ world, (.inl input : (OracleWorld + SigningSpec).Domain) = .inl world →
+          hashInputs (liftM (OracleWorld.query world)) ⊆ inputs :=
+        fun world heq => by cases heq; exact (hashInputs_world_query input next).trans hinputs
+      have hsign : ∀ message, (.inl input : (OracleWorld + SigningSpec).Domain) = .inr message →
+          hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs := fun message heq => by cases heq
+      obtain ⟨hstepAlive, hstepCons⟩ := exceptionStep_unstopped parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+        required (.inl input) state hvalid hworld hsign hcons halive hbudget step hstep (by omega)
+        (by simpa only [signingLogFragment, List.length_nil, Nat.add_zero] using hlog) hcleanState hcleanStep
+      have haccount := monitoredStep_account parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        (proposalStop (fun _ _ _ _ => false)) (.inl input) state.1 hvalid hworld hsign (step.1, step.2.1) hmon
+      have hspent := haccount.spent hstepAlive
+      have hlogStep := haccount.log hstepAlive
+      change step.2.1.2.spent = state.1.2.spent + step.1.1.2.hashCalls at hspent
+      change step.2.1.2.log = state.1.2.log ++ signingLogFragment (.inl input) step.1.1.1 at hlogStep
+      exact ih step.1.1.1 step.2
+        (monitoredStep_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          (proposalStop (fun _ _ _ _ => false)) (.inl input) state.1 hvalid _ hmon)
+        ((hashInputs_world_next input next step.1.1.1).trans hinputs) hstepCons hstepAlive tail htail (by rw [hspent]; omega)
+        (by rw [hlogStep]; simpa only [signingLogFragment, List.append_nil] using hlog) hclean
+
+include hauxiliary in
+theorem exceptionCompletedRun_unstopped (adversary : Adversary) (state : ExceptionState) (hvalid : Valid state.1)
+    (hcovered : CoveredRun parameter root otsSecret inputs (adversary.main ⟨root, parameter⟩) state.1) (hcons : Consistent parameter root state.1)
+    (halive : state.1.2.stopped = false) (hbudget : budget ≤ 2 ^ 127) (result : Completed × ExceptionState)
+    (hresult : exceptionCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+      (proposalStop (fun _ _ _ _ => false)) adversary state result ≠ 0)
+    (hcost : state.1.2.spent + completedWork result.1 ≤ budget) (hlog : state.1.2.log.length + result.1.1.1.1.2.length ≤ signatureLimit)
+    (hclean : result.2.2 = (false, false)) : result.2.1.2.stopped = false := by
+  rw [exceptionCompletedRun, RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨before, hbefore, hresult⟩ := hresult
+  obtain ⟨checked, hchecked, rfl⟩ := map_nonzero_source' _ _ _ hresult
+  have hcleanBefore := exceptionWorldRun_clean parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+    (proposalStop (fun _ _ _ _ => false)) _ before.2 checked hchecked hclean
+  simp only [completedWork] at hcost
+  obtain ⟨hbeforeAlive, hbeforeCons⟩ := exceptionRun_unstopped parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+    required hauxiliary (adversary.main ⟨root, parameter⟩) state hvalid hcovered hcons halive hbudget before hbefore (by omega) hlog hcleanBefore
+  have hforced := exceptionRun_forced parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+    (proposalStop (fun _ _ _ _ => false)) (adversary.main ⟨root, parameter⟩) state before hbefore
+  have hvalid' := monitoredRun_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+    (proposalStop (fun _ _ _ _ => false)) (adversary.main ⟨root, parameter⟩) state.1 hvalid _ hforced
+  have hfinal := monitoredRun_covered parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+    (proposalStop (fun _ _ _ _ => false)) hauxiliary (adversary.main ⟨root, parameter⟩) state.1 hvalid hcovered _ hforced
+  have haccount := monitoredRun_account parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+    (proposalStop (fun _ _ _ _ => false)) hauxiliary (adversary.main ⟨root, parameter⟩) state.1 hvalid hcovered _ hforced
+  have hspent := haccount.spent hbeforeAlive
+  have hlogBefore := haccount.log hbeforeAlive
+  change before.2.1.2.spent = state.1.2.spent + before.1.1.2.hashCalls at hspent
+  change before.2.1.2.log = state.1.2.log ++ before.1.1.1.2 at hlogBefore
+  exact (exceptionWorldRun_unstopped parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+    (verifyComputation parameter root before.1.1.1.1) before.2 hvalid'
+    (covered_pure parameter root otsSecret inputs before.1.1.1.1 before.2.1 hvalid' hfinal) hbeforeCons hbeforeAlive hbudget checked hchecked
+    (by rw [hspent]; omega) (by rw [hlogBefore, List.length_append]; omega) hclean).1
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessExceptionHistory.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessExceptionHistory.lean
new file mode 100644
index 000000000..480ad6741
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessExceptionHistory.lean
@@ -0,0 +1,341 @@
+import SphincsSecurity.Proof.Forced.FtsGuessMonitoredAccounting
+import SphincsSecurity.Proof.Residual.RetainedResidualCacheKernels
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec UniformTableCompletion OtsContactTrace ENNReal
+open FtsGuessSigning (Coordinate)
+open FtsProbeSimulation (MessageHashInput messageAnswers messageHashCharge)
+open SecretGuessObservation (State)
+open RetainedResidual (proposalOfSigningRecord proposalOfWorldResult nativeMessageCharge signingAnnotation)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  publicDigestLoop canonicalGraphRoot canonicalGraphInput hashInputs UniformTableCompletion.complete signDigestLoop
+  certificateCacheExceptionWeight
+
+variable (parameter : PublicParameter) (root : Digest)
+  (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+  (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+  (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (dummy : OtsReferenceWords) (slot : Nat)
+  (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+/-! ### Exception flags -/
+
+abbrev ExceptionState := MonitoredState × (Bool × Bool)
+
+noncomputable def exceptionUpdate (before after : MonitoredState) (history : Bool × Bool) : Bool × Bool :=
+  (history.1 || decide (CertificateCacheExceptional (monitorKey parameter root) before.1.1) ||
+    decide (CertificateCacheExceptional (monitorKey parameter root) after.1.1),
+   history.2 || decide (ProposalPrefixExceptional after.2.proposals after.2.log.length))
+
+noncomputable def exceptionStep (input : (OracleWorld + SigningSpec).Domain) (state : ExceptionState) :
+    SPMF (AdversaryStep input × ExceptionState) :=
+  (fun result => (result.1, (result.2, exceptionUpdate parameter root state.1 result.2 state.2))) <$>
+    monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state.1
+
+theorem exceptionStep_erasure (input : (OracleWorld + SigningSpec).Domain) (state : ExceptionState) :
+    (fun result => (result.1, result.2.1)) <$>
+        exceptionStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state =
+      monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state.1 := by
+  simp only [exceptionStep, Functor.map_map]
+  exact id_map _
+
+theorem exceptionStep_support (input : (OracleWorld + SigningSpec).Domain) (state : ExceptionState)
+    (result : AdversaryStep input × ExceptionState)
+    (hresult : exceptionStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state
+      result ≠ 0) :
+    monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state.1
+      (result.1, result.2.1) ≠ 0 ∧ result.2.2 = exceptionUpdate parameter root state.1 result.2.1 state.2 := by
+  obtain ⟨raw, hraw, heq⟩ := map_nonzero_source' _ _ _ hresult
+  cases heq
+  exact ⟨hraw, rfl⟩
+
+noncomputable def exceptionRun {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result) :
+    ExceptionState → SPMF ((((Result × QueryLog SigningSpec) × SigningBoundaryTrace) × Trace) × ExceptionState) :=
+  OracleComp.construct (fun value state => pure ((((value, []), 1), 1), state))
+    (fun input _ next state =>
+      exceptionStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state >>= fun step =>
+        (fun tail => (combineStep input step.1 tail.1, tail.2)) <$> next step.1.1.1 step.2) computation
+
+theorem exceptionRun_pure {Result : Type} (value : Result) (state : ExceptionState) :
+    exceptionRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter (pure value) state =
+      pure ((((value, []), 1), 1), state) := rfl
+
+theorem exceptionRun_query_bind {Result : Type} (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Result) (state : ExceptionState) :
+    exceptionRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      (liftM ((OracleWorld + SigningSpec).query input) >>= next) state =
+      (exceptionStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state >>= fun step =>
+        (fun tail => (combineStep input step.1 tail.1, tail.2)) <$>
+          exceptionRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+            (next step.1.1.1) step.2) := by
+  rw [exceptionRun, OracleComp.construct_query_bind]
+  rfl
+
+theorem exceptionRun_erasure {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result) (state : ExceptionState) :
+    (fun result => (result.1, result.2.1)) <$>
+        exceptionRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter computation state =
+      monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter computation state.1 := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => rw [exceptionRun_pure, monitoredRun_pure, map_pure]
+  | query_bind input next ih =>
+      rw [exceptionRun_query_bind, map_bind, monitoredRun_query_bind,
+        ← exceptionStep_erasure parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state,
+        bind_map_left]
+      apply congrArg (_ >>= ·)
+      funext step
+      rw [Functor.map_map, ← ih step.1.1.1 step.2, Functor.map_map]
+
+theorem exceptionRun_forced {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result) (state : ExceptionState)
+    (result : (((Result × QueryLog SigningSpec) × SigningBoundaryTrace) × Trace) × ExceptionState)
+    (hresult : exceptionRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      computation state result ≠ 0) :
+    monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter computation state.1
+      (result.1, result.2.1) ≠ 0 := by
+  have h := map_nonzero_of _ (fun result => (result.1, result.2.1)) result hresult
+  rwa [exceptionRun_erasure] at h
+
+theorem exceptionRun_clean {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result) (state : ExceptionState)
+    (result : (((Result × QueryLog SigningSpec) × SigningBoundaryTrace) × Trace) × ExceptionState)
+    (hresult : exceptionRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      computation state result ≠ 0) (hclean : result.2.2 = (false, false)) : state.2 = (false, false) := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      rw [exceptionRun_pure] at hresult
+      simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact hclean
+  | query_bind input next ih =>
+      rw [exceptionRun_query_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨step, hstep, hresult⟩ := hresult
+      obtain ⟨tail, htail, rfl⟩ := map_nonzero_source' _ _ _ hresult
+      have hafter : step.2.2 = (false, false) := ih step.1.1.1 step.2 tail htail hclean
+      have hupdate := (exceptionStep_support parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        input state step hstep).2
+      rw [hupdate] at hafter
+      simp only [exceptionUpdate, Prod.mk.injEq, Bool.or_eq_false_iff, decide_eq_false_iff_not] at hafter
+      exact Prod.ext hafter.1.1.1 hafter.2.1
+
+/-! ### Exception flags along the verifier -/
+
+noncomputable def exceptionWorldStep (input : OracleWorld.Domain) (state : ExceptionState) :
+    SPMF (AdversaryStep (.inl input) × ExceptionState) :=
+  exceptionStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter (.inl input) state
+
+noncomputable def exceptionWorldRun {Result : Type} (computation : OracleComp OracleWorld Result) :
+    ExceptionState → SPMF (((Result × SigningBoundaryTrace) × Trace) × ExceptionState) :=
+  OracleComp.construct (fun value state => pure (((value, 1), 1), state))
+    (fun input _ next state =>
+      exceptionWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state >>= fun step =>
+        (fun tail => (((tail.1.1.1, step.1.1.2 * tail.1.1.2), step.1.2 * tail.1.2), tail.2)) <$> next step.1.1.1 step.2) computation
+
+theorem exceptionWorldRun_pure {Result : Type} (value : Result) (state : ExceptionState) :
+    exceptionWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter (pure value) state =
+      pure (((value, 1), 1), state) := rfl
+
+theorem exceptionWorldRun_query_bind {Result : Type} (input : OracleWorld.Domain)
+    (next : OracleWorld.Range input → OracleComp OracleWorld Result) (state : ExceptionState) :
+    exceptionWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      (liftM (OracleWorld.query input) >>= next) state =
+      (exceptionWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state >>=
+        fun step => (fun tail => (((tail.1.1.1, step.1.1.2 * tail.1.1.2), step.1.2 * tail.1.2), tail.2)) <$>
+          exceptionWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+            (next step.1.1.1) step.2) := by
+  rw [exceptionWorldRun, OracleComp.construct_query_bind]
+  rfl
+
+theorem exceptionWorldStep_erasure (input : OracleWorld.Domain) (state : ExceptionState) :
+    (fun result => (result.1, result.2.1)) <$>
+        exceptionWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state =
+      monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state.1 :=
+  exceptionStep_erasure parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter (.inl input) state
+
+theorem exceptionWorldRun_erasure {Result : Type} (computation : OracleComp OracleWorld Result) (state : ExceptionState) :
+    (fun result => (result.1, result.2.1)) <$>
+        exceptionWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter computation state =
+      monitoredWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter computation state.1 := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => rw [exceptionWorldRun_pure, monitoredWorldRun_pure, map_pure]
+  | query_bind input next ih =>
+      rw [exceptionWorldRun_query_bind, map_bind, monitoredWorldRun_query_bind,
+        ← exceptionWorldStep_erasure parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input
+          state, bind_map_left]
+      apply congrArg (_ >>= ·)
+      funext step
+      rw [Functor.map_map, ← ih step.1.1.1 step.2, Functor.map_map]
+
+theorem exceptionWorldRun_clean {Result : Type} (computation : OracleComp OracleWorld Result) (state : ExceptionState)
+    (result : ((Result × SigningBoundaryTrace) × Trace) × ExceptionState)
+    (hresult : exceptionWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      computation state result ≠ 0) (hclean : result.2.2 = (false, false)) : state.2 = (false, false) := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      rw [exceptionWorldRun_pure] at hresult
+      simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact hclean
+  | query_bind input next ih =>
+      rw [exceptionWorldRun_query_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨step, hstep, hresult⟩ := hresult
+      obtain ⟨tail, htail, rfl⟩ := map_nonzero_source' _ _ _ hresult
+      have hafter : step.2.2 = (false, false) := ih step.1.1.1 step.2 tail htail hclean
+      have hupdate := (exceptionStep_support parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        (.inl input) state step hstep).2
+      rw [hupdate] at hafter
+      simp only [exceptionUpdate, Prod.mk.injEq, Bool.or_eq_false_iff, decide_eq_false_iff_not] at hafter
+      exact Prod.ext hafter.1.1.1 hafter.2.1
+
+noncomputable def exceptionCompletedRun (adversary : Adversary) (state : ExceptionState) : SPMF (Completed × ExceptionState) :=
+  exceptionRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+    (adversary.main ⟨root, parameter⟩) state >>= fun before =>
+    (fun checked => ((before.1, checked.1), checked.2)) <$>
+      exceptionWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        (verifyComputation parameter root before.1.1.1.1) before.2
+
+theorem exceptionCompletedRun_erasure (adversary : Adversary) (state : ExceptionState) :
+    (fun result => (result.1, result.2.1)) <$>
+        exceptionCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter adversary state =
+      monitoredCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter adversary
+        state.1 := by
+  rw [exceptionCompletedRun, monitoredCompletedRun_eq, map_bind, ← exceptionRun_erasure, bind_map_left]
+  apply congrArg (_ >>= ·)
+  funext before
+  rw [Functor.map_map, ← exceptionWorldRun_erasure, Functor.map_map]
+
+/-! ### Finite caches -/
+
+def Sized (state : MonitoredState) : Prop := ∃ bound : Nat, QueryCache.enncard state.1.1 ≤ bound
+
+theorem Sized.finite {state : MonitoredState} (hsized : Sized state) : Finite state.1.1 := by
+  obtain ⟨bound, hbound⟩ := hsized
+  exact Finite.of_enncard_le hbound
+
+theorem monitoredStep_sized (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState) (hvalid : Valid state)
+    (hworld : ∀ world, input = .inl world → hashInputs (liftM (OracleWorld.query world)) ⊆ inputs)
+    (hsign : ∀ message, input = .inr message → hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs)
+    (hsized : Sized state) (result : AdversaryStep input × MonitoredState)
+    (hresult : monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      input state result ≠ 0) : Sized result.2 := by
+  obtain ⟨bound, hbound⟩ := hsized
+  refine ⟨bound + result.1.1.2.hashCalls, ?_⟩
+  rw [Nat.cast_add]
+  exact (monitoredStep_account parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state
+    hvalid hworld hsign result hresult).enncard.trans (add_le_add hbound le_rfl)
+
+/-! ### The cache-exception weight along one step -/
+
+theorem tsum_probOutput_evalDist {Result : Type} (computation : ProbComp Result) (weight : Result → ENNReal) :
+    (∑' result, Pr[= result | 𝒟[computation]] * weight result) = ∑' result, Pr[= result | computation] * weight result := rfl
+
+theorem expected_forcedSigning_cacheWeight_le (message : Message) (state : MonitoredState) (hvalid : Valid state)
+    (hinputs : hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs) (hfinite : Finite state.1.1) :
+    (∑' result, Pr[= result | forcedSigning parameter root otsSecret labels inputs hencoding selections rows dummy slot message state] *
+      certificateCacheExceptionWeight (monitorKey parameter root) result.2.1) ≤
+      certificateCacheExceptionWeight (monitorKey parameter root) state.1.1 +
+        digestAttemptExpectation digestAttemptLimit (monitorKey parameter root) message state.1.1 * certificateCacheExceptionRate := by
+  rw [forcedSigning, cachedForcedRun_signingProgram' parameter root otsSecret labels inputs hencoding selections rows dummy slot message state.1
+    hvalid hinputs (referenceAnswers parameter root otsSecret labels inputs hencoding ⟨selections, rows, fun _ => 0⟩ dummy),
+    tsum_probOutput_bind_mul]
+  simp only [tsum_probOutput_map_mul]
+  have hwork := RetainedResidual.expected_publicSigningWork_cacheWeight_le (monitorKey parameter root) (referenceFamilyWords selections dummy)
+    selections (known otsSecret labels) message state.1.1 hfinite
+  have hlaw : (∑' result, Pr[= result | 𝒟[(simulateQ romImpl (Prod.fst <$> ResidualByteFrontend.publicSigningWork parameter root
+        (known otsSecret labels) (referenceFamilyWords selections dummy) selections message)).run state.1.1]] *
+      certificateCacheExceptionWeight (monitorKey parameter root) result.2) ≤
+      certificateCacheExceptionWeight (monitorKey parameter root) state.1.1 +
+        digestAttemptExpectation digestAttemptLimit (monitorKey parameter root) message state.1.1 * certificateCacheExceptionRate := by
+    have hparameter : (monitorKey parameter root).parameter = parameter := rfl
+    have hroot : (monitorKey parameter root).root = root := rfl
+    rw [hparameter, hroot] at hwork
+    rw [simulateQ_map, StateT.run_map, evalDist_map, tsum_probOutput_map_mul, tsum_probOutput_evalDist]
+    exact hwork
+  calc
+    _ ≤ ∑' secrets, Pr[= secrets | complete state.1.2.allowed] *
+        (certificateCacheExceptionWeight (monitorKey parameter root) state.1.1 +
+          digestAttemptExpectation digestAttemptLimit (monitorKey parameter root) message state.1.1 * certificateCacheExceptionRate) :=
+      ENNReal.tsum_le_tsum fun _ => mul_le_mul' le_rfl hlaw
+    _ ≤ _ := by
+      rw [ENNReal.tsum_mul_right]
+      exact mul_le_of_le_one_left' tsum_probOutput_le_one
+
+theorem expected_worldStep_cacheWeight_le (input : OracleWorld.Domain) (state : MonitoredState)
+    (hinputs : hashInputs (liftM (OracleWorld.query input)) ⊆ inputs) (hfinite : Finite state.1.1) :
+    (∑' result, Pr[= result | cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+        (worldProgram parameter labels input) state.1] * certificateCacheExceptionWeight (monitorKey parameter root) result.2.1) ≤
+      certificateCacheExceptionWeight (monitorKey parameter root) state.1.1 +
+        nativeMessageCharge (monitorKey parameter root) (.inl input) (monitorView state) * certificateCacheExceptionRate := by
+  have hpointwise (hmono : ∀ result, cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+      (worldProgram parameter labels input) state.1 result ≠ 0 →
+      certificateCacheExceptionWeight (monitorKey parameter root) result.2.1 ≤ certificateCacheExceptionWeight (monitorKey parameter root) state.1.1) :
+      (∑' result, Pr[= result | cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+        (worldProgram parameter labels input) state.1] * certificateCacheExceptionWeight (monitorKey parameter root) result.2.1) ≤
+        certificateCacheExceptionWeight (monitorKey parameter root) state.1.1 := by
+    calc
+      _ ≤ ∑' result, Pr[= result | cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+          (worldProgram parameter labels input) state.1] * certificateCacheExceptionWeight (monitorKey parameter root) state.1.1 := by
+        apply ENNReal.tsum_le_tsum
+        intro result
+        by_cases hr : Pr[= result | cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+            (worldProgram parameter labels input) state.1] = 0
+        · simp only [hr, zero_mul, le_refl]
+        · rw [SPMF.probOutput_eq_apply] at hr
+          exact mul_le_mul' le_rfl (hmono result hr)
+      _ ≤ _ := by
+        rw [ENNReal.tsum_mul_right]
+        exact mul_le_of_le_one_left' tsum_probOutput_le_one
+  cases input with
+  | inl sample =>
+      refine (hpointwise fun result hr => ?_).trans le_self_add
+      rw [cachedForcedRun_world_unif'] at hr
+      obtain ⟨answer, _, rfl⟩ := map_nonzero_source' _ _ _ hr
+      exact le_rfl
+  | inr hash =>
+      have hin : hash ∈ inputs := hinputs (by simpa only [bind_pure] using mem_hashInputs_hash_bind hash pure)
+      by_cases hmessage : MessageHashInput parameter hash
+      · rw [cachedForcedRun_world_message' parameter root otsSecret labels inputs hencoding selections rows dummy slot hash hin hmessage state.1,
+          tsum_probOutput_map_mul]
+        have h := expected_certificateCacheExceptionWeight_rom (monitorKey parameter root) (.inr hash) state.1.1 hfinite
+        rw [tsum_probOutput_evalDist]
+        exact h
+      · refine (hpointwise fun result hr => ?_).trans le_self_add
+        have hsupport := cachedForcedRun_world_hash_support' parameter root otsSecret labels inputs hencoding selections rows dummy slot hash
+          state.1 result hr
+        have hafter : Finite result.2.1 := by
+          have hbound : QueryCache.enncard state.1.1 ≤ (({input | state.1.1 input ≠ none}.ncard : Nat) : ENNReal) :=
+            hfinite.cachedInputs_ncard_toENNReal_eq_enncard.symm.le
+          exact Finite.of_enncard_le (q := {input | state.1.1 input ≠ none}.ncard + 1)
+            (hsupport.2.2.trans (by rw [Nat.cast_add, Nat.cast_one]; exact add_le_add hbound le_rfl))
+        exact certificateCacheExceptionWeight_messageAnswers_le (monitorKey parameter root) state.1.1 result.2.1 hafter
+          (messageAnswers_eq_of_cache_of_ne parameter state.1.1 result.2.1 hash hmessage hsupport.1).symm
+          (QueryCache.enncard_mono hsupport.2.1)
+
+theorem expected_monitoredStep_cacheWeight_le (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState) (hvalid : Valid state)
+    (hworld : ∀ world, input = .inl world → hashInputs (liftM (OracleWorld.query world)) ⊆ inputs)
+    (hsign : ∀ message, input = .inr message → hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs)
+    (hfinite : Finite state.1.1) :
+    (∑' result, Pr[= result | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter input state] * certificateCacheExceptionWeight (monitorKey parameter root) result.2.1.1) ≤
+      certificateCacheExceptionWeight (monitorKey parameter root) state.1.1 +
+        nativeMessageCharge (monitorKey parameter root) input (monitorView state) * certificateCacheExceptionRate := by
+  cases input with
+  | inl input =>
+      rw [monitoredStep, monitoredWorldStep, tsum_probOutput_map_mul]
+      exact expected_worldStep_cacheWeight_le parameter root otsSecret labels inputs hencoding selections rows dummy slot input state
+        (hworld input rfl) hfinite
+  | inr message =>
+      rw [monitoredStep, monitoredSignStep_eq, tsum_probOutput_bind_mul]
+      simp only [tsum_probOutput_map_mul]
+      calc
+        _ ≤ ∑' annotation, Pr[= annotation | (liftM (signingAnnotation (monitorKey parameter root) budget message (monitorView state)) : SPMF _)] *
+            (certificateCacheExceptionWeight (monitorKey parameter root) state.1.1 +
+              digestAttemptExpectation digestAttemptLimit (monitorKey parameter root) message state.1.1 * certificateCacheExceptionRate) := by
+          apply ENNReal.tsum_le_tsum
+          intro annotation
+          apply mul_le_mul' le_rfl
+          exact expected_forcedSigning_cacheWeight_le parameter root otsSecret labels inputs hencoding selections rows dummy slot message state
+            hvalid (hsign message rfl) hfinite
+        _ ≤ _ := by
+          rw [ENNReal.tsum_mul_right]
+          exact mul_le_of_le_one_left' tsum_probOutput_le_one
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessExceptionWeights.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessExceptionWeights.lean
new file mode 100644
index 000000000..44765d9a5
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessExceptionWeights.lean
@@ -0,0 +1,479 @@
+import SphincsSecurity.Proof.Forced.FtsGuessExceptionBounds
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec UniformTableCompletion OtsContactTrace ENNReal
+open FtsGuessSigning (Coordinate)
+open FtsProbeSimulation (MessageHashInput messageAnswers messageHashCharge)
+open SecretGuessObservation (State)
+open RetainedResidual (proposalOfSigningRecord proposalOfWorldResult nativeMessageCharge signingAnnotation)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  publicDigestLoop canonicalGraphRoot canonicalGraphInput hashInputs UniformTableCompletion.complete signDigestLoop
+  certificateCacheExceptionWeight
+
+variable (parameter : PublicParameter) (root : Digest)
+  (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+  (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+  (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (dummy : OtsReferenceWords) (slot : Nat)
+  (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+/-! ### The cache-exception weight along runs -/
+
+noncomputable def cacheHistoryWeight (state : ExceptionState) : ENNReal :=
+  if state.2.1 then 1 else certificateCacheExceptionWeight (monitorKey parameter root) state.1.1.1
+
+theorem expected_exceptionStep_cacheWeight_le (input : (OracleWorld + SigningSpec).Domain) (state : ExceptionState) (hvalid : Valid state.1)
+    (hworld : ∀ world, input = .inl world → hashInputs (liftM (OracleWorld.query world)) ⊆ inputs)
+    (hsign : ∀ message, input = .inr message → hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs)
+    (hsized : Sized state.1) :
+    (∑' result, Pr[= result | exceptionStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        input state] * cacheHistoryWeight parameter root result.2) ≤
+      cacheHistoryWeight parameter root state +
+        nativeMessageCharge (monitorKey parameter root) input (monitorView state.1) * certificateCacheExceptionRate := by
+  rw [exceptionStep, tsum_probOutput_map_mul]
+  cases hflag : state.2.1 with
+  | true =>
+      simp only [cacheHistoryWeight, exceptionUpdate, hflag, Bool.true_or, ite_true, mul_one]
+      exact tsum_probOutput_le_one.trans le_self_add
+  | false =>
+      conv_rhs => simp only [cacheHistoryWeight, hflag, Bool.false_eq_true, if_false]
+      by_cases hbefore : CertificateCacheExceptional (monitorKey parameter root) state.1.1.1
+      · simp only [cacheHistoryWeight, exceptionUpdate, hflag, Bool.false_or, decide_eq_true hbefore, Bool.true_or, ite_true, mul_one]
+        exact tsum_probOutput_le_one.trans ((certificateCacheExceptionWeight_bad (monitorKey parameter root) _ hsized.finite hbefore).trans
+          le_self_add)
+      · apply le_trans ?_ (expected_monitoredStep_cacheWeight_le parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+          required stopAfter input state.1 hvalid hworld hsign hsized.finite)
+        apply ENNReal.tsum_le_tsum
+        intro result
+        by_cases hr : Pr[= result | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+            stopAfter input state.1] = 0
+        · simp only [hr, zero_mul, le_refl]
+        · rw [SPMF.probOutput_eq_apply] at hr
+          apply mul_le_mul' le_rfl
+          have hafter := monitoredStep_sized parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+            input state.1 hvalid hworld hsign hsized result hr
+          simp only [cacheHistoryWeight, exceptionUpdate, hflag, Bool.false_or, decide_eq_false hbefore, Bool.false_or, decide_eq_true_eq]
+          split
+          · exact certificateCacheExceptionWeight_bad (monitorKey parameter root) _ hafter.finite (by assumption)
+          · exact le_rfl
+
+variable (hauxiliary : ∀ seed : inputs → HashOutput,
+  (⟨selections, rows, seed⟩ : ReferenceAuxiliary inputs) ∈ (referenceAuxiliarySample inputs).support)
+
+include hauxiliary in
+theorem expected_exceptionRun_cacheWeight_le (computation : OracleComp (OracleWorld + SigningSpec) Forgery) (state : ExceptionState)
+    (hvalid : Valid state.1) (hcovered : CoveredRun parameter root otsSecret inputs computation state.1) (hsized : Sized state.1) :
+    (∑' result, Pr[= result | exceptionRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        computation state] * cacheHistoryWeight parameter root result.2) ≤
+      cacheHistoryWeight parameter root state +
+        expectedMonitoredPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          (fun input current => nativeMessageCharge (monitorKey parameter root) input current * certificateCacheExceptionRate) computation
+          state.1 := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [exceptionRun_pure, tsum_probOutput_pure_mul, expectedMonitoredPayment, construct_pure, add_zero, le_refl]
+  | query_bind input next ih =>
+      rw [exceptionRun_query_bind, tsum_probOutput_bind_mul, expectedMonitoredPayment_query_bind]
+      have hworld : ∀ world, input = .inl world → hashInputs (liftM (OracleWorld.query world)) ⊆ inputs :=
+        fun world heq => by subst heq; exact covered_world_inputs parameter root otsSecret inputs world next state.1 hvalid hcovered
+      have hsign := covered_step_digest parameter root otsSecret inputs input next state.1 hvalid hcovered
+      let payment (result : AdversaryStep input × MonitoredState) : ENNReal :=
+        expectedMonitoredPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          (fun input current => nativeMessageCharge (monitorKey parameter root) input current * certificateCacheExceptionRate)
+          (next result.1.1.1) result.2
+      have herasure : (∑' result, Pr[= result | exceptionStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+          required stopAfter input state] * payment (result.1, result.2.1)) =
+          ∑' result, Pr[= result | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+            stopAfter input state.1] * payment result := by
+        have h := congrArg (fun law : SPMF (AdversaryStep input × MonitoredState) => ∑' result, Pr[= result | law] * payment result)
+          (exceptionStep_erasure parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state)
+        rw [tsum_probOutput_map_mul] at h
+        exact h
+      calc
+        _ ≤ ∑' result, Pr[= result | exceptionStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+              stopAfter input state] * (cacheHistoryWeight parameter root result.2 + payment (result.1, result.2.1)) := by
+          apply ENNReal.tsum_le_tsum
+          intro result
+          by_cases hr : Pr[= result | exceptionStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+              stopAfter input state] = 0
+          · simp only [hr, zero_mul, le_refl]
+          · rw [SPMF.probOutput_eq_apply] at hr
+            have hn := (exceptionStep_support parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+              input state result hr).1
+            apply mul_le_mul' le_rfl
+            rw [tsum_probOutput_map_mul]
+            exact ih result.1.1.1 result.2
+              (monitoredStep_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input
+                state.1 hvalid _ hn)
+              (covered_step_next parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter hauxiliary
+                input next state.1 hvalid hcovered _ hn)
+              (monitoredStep_sized parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input
+                state.1 hvalid hworld hsign hsized _ hn)
+        _ ≤ (cacheHistoryWeight parameter root state +
+              nativeMessageCharge (monitorKey parameter root) input (monitorView state.1) * certificateCacheExceptionRate) +
+            ∑' result, Pr[= result | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+              stopAfter input state.1] * payment result := by
+          simp only [mul_add, ENNReal.tsum_add]
+          rw [herasure]
+          exact add_le_add (expected_exceptionStep_cacheWeight_le parameter root otsSecret labels inputs hencoding selections rows dummy slot
+            budget required stopAfter input state hvalid hworld hsign hsized) le_rfl
+        _ = _ := add_assoc _ _ _
+
+theorem expected_exceptionWorldRun_cacheWeight_le {Result : Type} (computation : OracleComp OracleWorld Result) (state : ExceptionState)
+    (hvalid : Valid state.1) (hinputs : hashInputs computation ⊆ inputs) (hsized : Sized state.1) :
+    (∑' result, Pr[= result | exceptionWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter computation state] * cacheHistoryWeight parameter root result.2) ≤
+      cacheHistoryWeight parameter root state +
+        expectedWorldPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          (fun input current => nativeMessageCharge (monitorKey parameter root) input current * certificateCacheExceptionRate) computation
+          state.1 := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [exceptionWorldRun_pure, tsum_probOutput_pure_mul, expectedWorldPayment, construct_pure, add_zero, le_refl]
+  | query_bind input next ih =>
+      rw [exceptionWorldRun_query_bind, tsum_probOutput_bind_mul, expectedWorldPayment_query_bind]
+      have hworld : ∀ world, (.inl input : (OracleWorld + SigningSpec).Domain) = .inl world →
+          hashInputs (liftM (OracleWorld.query world)) ⊆ inputs :=
+        fun world heq => by cases heq; exact (hashInputs_world_query input next).trans hinputs
+      have hsign : ∀ message, (.inl input : (OracleWorld + SigningSpec).Domain) = .inr message →
+          hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs := fun message heq => by cases heq
+      let payment (result : AdversaryStep (.inl input) × MonitoredState) : ENNReal :=
+        expectedWorldPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          (fun input current => nativeMessageCharge (monitorKey parameter root) input current * certificateCacheExceptionRate)
+          (next result.1.1.1) result.2
+      have herasure : (∑' result, Pr[= result | exceptionWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+          required stopAfter input state] * payment (result.1, result.2.1)) =
+          ∑' result, Pr[= result | monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+            stopAfter input state.1] * payment result := by
+        have h := congrArg (fun law : SPMF (AdversaryStep (.inl input) × MonitoredState) => ∑' result, Pr[= result | law] * payment result)
+          (exceptionWorldStep_erasure parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input
+            state)
+        rw [tsum_probOutput_map_mul] at h
+        exact h
+      calc
+        _ ≤ ∑' result, Pr[= result | exceptionWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+              stopAfter input state] * (cacheHistoryWeight parameter root result.2 + payment (result.1, result.2.1)) := by
+          apply ENNReal.tsum_le_tsum
+          intro result
+          by_cases hr : Pr[= result | exceptionWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+              required stopAfter input state] = 0
+          · simp only [hr, zero_mul, le_refl]
+          · rw [SPMF.probOutput_eq_apply] at hr
+            have hn := (exceptionStep_support parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+              (.inl input) state result hr).1
+            apply mul_le_mul' le_rfl
+            rw [tsum_probOutput_map_mul]
+            exact ih result.1.1.1 result.2
+              (monitoredStep_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter (.inl input)
+                state.1 hvalid _ hn)
+              ((hashInputs_world_next input next result.1.1.1).trans hinputs)
+              (monitoredStep_sized parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter (.inl input)
+                state.1 hvalid hworld hsign hsized _ hn)
+        _ ≤ (cacheHistoryWeight parameter root state +
+              nativeMessageCharge (monitorKey parameter root) (.inl input) (monitorView state.1) * certificateCacheExceptionRate) +
+            ∑' result, Pr[= result | monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+              stopAfter input state.1] * payment result := by
+          simp only [mul_add, ENNReal.tsum_add]
+          rw [herasure]
+          exact add_le_add (expected_exceptionStep_cacheWeight_le parameter root otsSecret labels inputs hencoding selections rows dummy slot
+            budget required stopAfter (.inl input) state hvalid hworld hsign hsized) le_rfl
+        _ = _ := add_assoc _ _ _
+
+include hauxiliary in
+theorem exceptionRun_sized (computation : OracleComp (OracleWorld + SigningSpec) Forgery) (state : ExceptionState) (hvalid : Valid state.1)
+    (hcovered : CoveredRun parameter root otsSecret inputs computation state.1) (hsized : Sized state.1)
+    (result : AdversaryTrace × ExceptionState)
+    (hresult : exceptionRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      computation state result ≠ 0) : Sized result.2.1 := by
+  obtain ⟨bound, hbound⟩ := hsized
+  refine ⟨bound + result.1.1.2.hashCalls, ?_⟩
+  rw [Nat.cast_add]
+  have haccount := monitoredRun_account parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+    hauxiliary computation state.1 hvalid hcovered (result.1, result.2.1)
+    (exceptionRun_forced parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter computation state
+      result hresult)
+  exact haccount.enncard.trans (add_le_add hbound le_rfl)
+
+include hauxiliary in
+theorem expected_exceptionCompletedRun_cacheWeight_le (adversary : Adversary) (state : ExceptionState) (hvalid : Valid state.1)
+    (hcovered : CoveredRun parameter root otsSecret inputs (adversary.main ⟨root, parameter⟩) state.1) (hsized : Sized state.1) :
+    (∑' result, Pr[= result | exceptionCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter adversary state] * cacheHistoryWeight parameter root result.2) ≤
+      cacheHistoryWeight parameter root state +
+        (expectedMonitoredPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          (nativeMessageCharge (monitorKey parameter root)) (adversary.main ⟨root, parameter⟩) state.1 +
+        ∑' before, Pr[= before | monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          (adversary.main ⟨root, parameter⟩) state.1] *
+          expectedWorldPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+            (nativeMessageCharge (monitorKey parameter root)) (verifyComputation parameter root before.1.1.1.1) before.2) *
+        certificateCacheExceptionRate := by
+  rw [exceptionCompletedRun, tsum_probOutput_bind_mul]
+  let worldPayment (before : AdversaryTrace × MonitoredState) : ENNReal :=
+    expectedWorldPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      (fun input current => nativeMessageCharge (monitorKey parameter root) input current * certificateCacheExceptionRate)
+      (verifyComputation parameter root before.1.1.1.1) before.2
+  have herasure : (∑' before, Pr[= before | exceptionRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+      stopAfter (adversary.main ⟨root, parameter⟩) state] * worldPayment (before.1, before.2.1)) =
+      ∑' before, Pr[= before | monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        (adversary.main ⟨root, parameter⟩) state.1] * worldPayment before := by
+    have h := congrArg (fun law : SPMF (AdversaryTrace × MonitoredState) => ∑' before, Pr[= before | law] * worldPayment before)
+      (exceptionRun_erasure parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        (adversary.main ⟨root, parameter⟩) state)
+    rw [tsum_probOutput_map_mul] at h
+    exact h
+  calc
+    _ ≤ ∑' before, Pr[= before | exceptionRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          (adversary.main ⟨root, parameter⟩) state] * (cacheHistoryWeight parameter root before.2 + worldPayment (before.1, before.2.1)) := by
+      apply ENNReal.tsum_le_tsum
+      intro before
+      by_cases hb : Pr[= before | exceptionRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter (adversary.main ⟨root, parameter⟩) state] = 0
+      · simp only [hb, zero_mul, le_refl]
+      · rw [SPMF.probOutput_eq_apply] at hb
+        have hforced := exceptionRun_forced parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          (adversary.main ⟨root, parameter⟩) state before hb
+        have hvalid' := monitoredRun_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          (adversary.main ⟨root, parameter⟩) state.1 hvalid _ hforced
+        have hfinal := monitoredRun_covered parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          hauxiliary (adversary.main ⟨root, parameter⟩) state.1 hvalid hcovered _ hforced
+        apply mul_le_mul' le_rfl
+        rw [tsum_probOutput_map_mul]
+        exact expected_exceptionWorldRun_cacheWeight_le parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter (verifyComputation parameter root before.1.1.1.1) before.2 hvalid'
+          (covered_pure parameter root otsSecret inputs before.1.1.1.1 before.2.1 hvalid' hfinal)
+          (exceptionRun_sized parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter hauxiliary
+            (adversary.main ⟨root, parameter⟩) state hvalid hcovered hsized before hb)
+    _ ≤ (cacheHistoryWeight parameter root state +
+          expectedMonitoredPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+            (fun input current => nativeMessageCharge (monitorKey parameter root) input current * certificateCacheExceptionRate)
+            (adversary.main ⟨root, parameter⟩) state.1) +
+        ∑' before, Pr[= before | monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          (adversary.main ⟨root, parameter⟩) state.1] * worldPayment before := by
+      simp only [mul_add, ENNReal.tsum_add]
+      rw [herasure]
+      exact add_le_add (expected_exceptionRun_cacheWeight_le parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+        required stopAfter hauxiliary (adversary.main ⟨root, parameter⟩) state hvalid hcovered hsized) le_rfl
+    _ = _ := by
+      rw [add_assoc, add_mul, expectedMonitoredPayment_mul, ← ENNReal.tsum_mul_right]
+      congr 2
+      apply tsum_congr
+      intro before
+      rw [mul_assoc]
+      apply congrArg (_ * ·)
+      exact expectedWorldPayment_mul parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter _ _ _ _
+
+include hauxiliary in
+theorem exceptionCompletedRun_cache_le (adversary : Adversary) (state : ExceptionState) (hvalid : Valid state.1)
+    (hcovered : CoveredRun parameter root otsSecret inputs (adversary.main ⟨root, parameter⟩) state.1) (hsized : Sized state.1) :
+    Pr[fun result => result.2.2.1 = true | exceptionCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+        budget required stopAfter adversary state] ≤
+      cacheHistoryWeight parameter root state +
+        (∑' result, Pr[= result | monitoredCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter adversary state.1] * (completedWork result.1 : ENNReal)) * certificateCacheExceptionRate := by
+  refine le_trans ?_ ((expected_exceptionCompletedRun_cacheWeight_le parameter root otsSecret labels inputs hencoding selections rows dummy slot
+    budget required stopAfter hauxiliary adversary state hvalid hcovered hsized).trans (add_le_add le_rfl (mul_le_mul'
+      (expectedCompletedPayment_le_work parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        hauxiliary adversary state.1 hvalid hcovered) le_rfl)))
+  apply probEvent_le_tsum_probOutput_mul_cost_of_mem_support
+  intro result _ hflag
+  simp only [cacheHistoryWeight, hflag, ite_true, le_refl]
+
+/-! ### The proposal-prefix weight along runs -/
+
+noncomputable def prefixHistoryWeight (state : ExceptionState) : ENNReal :=
+  if state.2.2 then 1 else proposalPrefixWeight state.1.2.proposals state.1.2.log.length
+
+private theorem update_log_cap (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState) (length : Nat)
+    (record : ProposalExecutionRecord input) (hcap : state.2.log.length ≤ signatureLimit) :
+    (certificateMonitorUpdate (monitorKey parameter root) budget required stopAfter input state length record).log.length ≤ signatureLimit := by
+  by_cases hactive : CertificateMonitorActive (monitorKey parameter root) budget input state
+  · rw [certificateMonitorUpdate, if_pos hactive]
+    have hvalid := hactive.2.2.1
+    cases input <;>
+      simp only [proposalRecordLogState, signingLogFragment, List.append_nil, List.length_append, List.length_singleton,
+        ValidSigningStep] at hvalid ⊢ <;> omega
+  · simpa only [certificateMonitorUpdate, if_neg hactive] using hcap
+
+theorem monitoredStep_log_cap (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState) (hcap : state.2.log.length ≤ signatureLimit)
+    (result : AdversaryStep input × MonitoredState)
+    (hresult : monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state
+      result ≠ 0) : result.2.2.log.length ≤ signatureLimit := by
+  cases input with
+  | inl input =>
+      rw [monitoredStep, monitoredWorldStep] at hresult
+      obtain ⟨raw, _, rfl⟩ := map_nonzero_source' _ _ _ hresult
+      exact update_log_cap parameter root budget required stopAfter (.inl input) (monitorView state) 0 _ hcap
+  | inr message =>
+      rw [monitoredStep, monitoredSignStep_eq, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨annotation, _, hresult⟩ := hresult
+      obtain ⟨raw, _, rfl⟩ := map_nonzero_source' _ _ _ hresult
+      exact update_log_cap parameter root budget required stopAfter (.inr message) (monitorView state) annotation.1 _ hcap
+
+private theorem world_weight (input : OracleWorld.Domain) (state : MonitoredState) (raw : OracleWorld.Range input × CachedState) :
+    proposalPrefixWeight
+        (certificateMonitorUpdate (monitorKey parameter root) budget required stopAfter (.inl input) (monitorView state) 0
+          (proposalOfWorldResult parameter input (raw.1, raw.2.1))).proposals
+        (certificateMonitorUpdate (monitorKey parameter root) budget required stopAfter (.inl input) (monitorView state) 0
+          (proposalOfWorldResult parameter input (raw.1, raw.2.1))).log.length =
+      proposalPrefixWeight state.2.proposals state.2.log.length := by
+  simp only [certificateMonitorUpdate]
+  split <;> simp only [proposalRecordLogState, signingLogFragment, List.append_nil, Nat.add_zero, monitorView]
+
+private theorem signing_weight (message : Message) (annotation : Nat × Index) (state : MonitoredState)
+    (raw : ((Option Signature × Option FewTimeView) × SigningBoundaryTrace) × CachedState) :
+    proposalPrefixWeight (signResult parameter root budget required stopAfter message annotation state raw).2.2.proposals
+        (signResult parameter root budget required stopAfter message annotation state raw).2.2.log.length =
+      if CertificateMonitorActive (monitorKey parameter root) budget (.inr message) (monitorView state) then
+        proposalPrefixWeight (state.2.proposals + annotation.1) (state.2.log.length + 1)
+      else proposalPrefixWeight state.2.proposals state.2.log.length := by
+  simp only [signResult, certificateMonitorUpdate]
+  split <;> simp only [proposalRecordLogState, signingLogFragment, List.length_append, List.length_singleton, monitorView]
+
+theorem expected_monitoredStep_prefixWeight_le (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState) :
+    (∑' result, Pr[= result | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        input state] * proposalPrefixWeight result.2.2.proposals result.2.2.log.length) ≤
+      proposalPrefixWeight state.2.proposals state.2.log.length := by
+  cases input with
+  | inl input =>
+      rw [monitoredStep, monitoredWorldStep, tsum_probOutput_map_mul]
+      simp only [world_weight, ENNReal.tsum_mul_right]
+      exact mul_le_of_le_one_left' tsum_probOutput_le_one
+  | inr message =>
+      rw [monitoredStep, monitoredSignStep_eq, tsum_probOutput_bind_mul]
+      simp only [tsum_probOutput_map_mul, signing_weight, ENNReal.tsum_mul_right]
+      by_cases hactive : CertificateMonitorActive (monitorKey parameter root) budget (.inr message) (monitorView state)
+      · simp only [if_pos hactive]
+        calc
+          _ ≤ ∑' annotation, Pr[= annotation | (liftM (signingAnnotation (monitorKey parameter root) budget message (monitorView state)) : SPMF _)] *
+              proposalPrefixWeight (state.2.proposals + annotation.1) (state.2.log.length + 1) :=
+            ENNReal.tsum_le_tsum fun _ => mul_le_mul' le_rfl (mul_le_of_le_one_left' tsum_probOutput_le_one)
+          _ = proposalPrefixWeight state.2.proposals state.2.log.length := by
+            simp only [SPMF.probOutput_liftM]
+            rw [signingAnnotation, if_pos hactive, ← PMF.monad_bind_eq_bind, tsum_probOutput_bind_mul]
+            simp_rw [← PMF.monad_map_eq_map, tsum_probOutput_map_mul]
+            simp only [ENNReal.tsum_mul_right, PMF.probOutput_eq_apply, PMF.tsum_coe, one_mul]
+            exact expected_proposalPrefixWeight state.2.proposals state.2.log.length hactive.2.2.1
+      · simp only [if_neg hactive, ENNReal.tsum_mul_right]
+        exact (mul_le_of_le_one_left' tsum_probOutput_le_one).trans (mul_le_of_le_one_left' tsum_probOutput_le_one)
+
+theorem expected_exceptionStep_prefixWeight_le (input : (OracleWorld + SigningSpec).Domain) (state : ExceptionState)
+    (hcap : state.1.2.log.length ≤ signatureLimit) :
+    (∑' result, Pr[= result | exceptionStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        input state] * prefixHistoryWeight result.2) ≤ prefixHistoryWeight state := by
+  rw [exceptionStep, tsum_probOutput_map_mul]
+  cases hflag : state.2.2 with
+  | true =>
+      simp only [prefixHistoryWeight, exceptionUpdate, hflag, Bool.true_or, ite_true, mul_one]
+      exact tsum_probOutput_le_one
+  | false =>
+      conv_rhs => simp only [prefixHistoryWeight, hflag, Bool.false_eq_true, if_false]
+      apply le_trans ?_ (expected_monitoredStep_prefixWeight_le parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+        required stopAfter input state.1)
+      apply ENNReal.tsum_le_tsum
+      intro result
+      by_cases hr : Pr[= result | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter input state.1] = 0
+      · simp only [hr, zero_mul, le_refl]
+      · rw [SPMF.probOutput_eq_apply] at hr
+        apply mul_le_mul' le_rfl
+        have hcap' := monitoredStep_log_cap parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          input state.1 hcap result hr
+        simp only [prefixHistoryWeight, exceptionUpdate, hflag, Bool.false_or, decide_eq_true_eq]
+        split
+        · exact proposalPrefixWeight_bad _ _ hcap' (by assumption)
+        · exact le_rfl
+
+theorem expected_exceptionRun_prefixWeight_le {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : ExceptionState) (hcap : state.1.2.log.length ≤ signatureLimit) :
+    (∑' result, Pr[= result | exceptionRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        computation state] * prefixHistoryWeight result.2) ≤ prefixHistoryWeight state := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [exceptionRun_pure, tsum_probOutput_pure_mul, le_refl]
+  | query_bind input next ih =>
+      rw [exceptionRun_query_bind, tsum_probOutput_bind_mul]
+      apply le_trans ?_ (expected_exceptionStep_prefixWeight_le parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+        required stopAfter input state hcap)
+      apply ENNReal.tsum_le_tsum
+      intro result
+      by_cases hr : Pr[= result | exceptionStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter input state] = 0
+      · simp only [hr, zero_mul, le_refl]
+      · rw [SPMF.probOutput_eq_apply] at hr
+        have hn := (exceptionStep_support parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          input state result hr).1
+        have hc := monitoredStep_log_cap parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          input state.1 hcap _ hn
+        apply mul_le_mul' le_rfl
+        rw [tsum_probOutput_map_mul]
+        exact ih result.1.1.1 result.2 hc
+
+theorem expected_exceptionWorldRun_prefixWeight_le {Result : Type} (computation : OracleComp OracleWorld Result) (state : ExceptionState)
+    (hcap : state.1.2.log.length ≤ signatureLimit) :
+    (∑' result, Pr[= result | exceptionWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter computation state] * prefixHistoryWeight result.2) ≤ prefixHistoryWeight state := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [exceptionWorldRun_pure, tsum_probOutput_pure_mul, le_refl]
+  | query_bind input next ih =>
+      rw [exceptionWorldRun_query_bind, tsum_probOutput_bind_mul]
+      apply le_trans ?_ (expected_exceptionStep_prefixWeight_le parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+        required stopAfter (.inl input) state hcap)
+      apply ENNReal.tsum_le_tsum
+      intro result
+      by_cases hr : Pr[= result | exceptionWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter input state] = 0
+      · simp only [hr, zero_mul]
+        exact zero_le
+      · rw [SPMF.probOutput_eq_apply] at hr
+        have hn := (exceptionStep_support parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          (.inl input) state result hr).1
+        have hc := monitoredStep_log_cap parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          (.inl input) state.1 hcap _ hn
+        apply mul_le_mul' le_rfl
+        rw [tsum_probOutput_map_mul]
+        exact ih result.1.1.1 result.2 hc
+
+theorem exceptionRun_log_cap (computation : OracleComp (OracleWorld + SigningSpec) Forgery) (state : ExceptionState)
+    (hcap : state.1.2.log.length ≤ signatureLimit) (result : AdversaryTrace × ExceptionState)
+    (hresult : exceptionRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      computation state result ≠ 0) : result.2.1.2.log.length ≤ signatureLimit := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      rw [exceptionRun_pure] at hresult
+      simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact hcap
+  | query_bind input next ih =>
+      rw [exceptionRun_query_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨step, hstep, hresult⟩ := hresult
+      obtain ⟨tail, htail, rfl⟩ := map_nonzero_source' _ _ _ hresult
+      have hn := (exceptionStep_support parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input
+        state step hstep).1
+      exact ih step.1.1.1 step.2
+        (monitoredStep_log_cap parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state.1
+          hcap _ hn) tail htail
+
+theorem exceptionCompletedRun_prefix_le (adversary : Adversary) (state : ExceptionState) (hcap : state.1.2.log.length ≤ signatureLimit) :
+    Pr[fun result => result.2.2.2 = true | exceptionCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+        required stopAfter adversary state] ≤ prefixHistoryWeight state := by
+  have hweight : (∑' result, Pr[= result | exceptionCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+      required stopAfter adversary state] * prefixHistoryWeight result.2) ≤ prefixHistoryWeight state := by
+    rw [exceptionCompletedRun, tsum_probOutput_bind_mul]
+    apply le_trans ?_ (expected_exceptionRun_prefixWeight_le parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+      required stopAfter (adversary.main ⟨root, parameter⟩) state hcap)
+    apply ENNReal.tsum_le_tsum
+    intro before
+    by_cases hb : Pr[= before | exceptionRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        (adversary.main ⟨root, parameter⟩) state] = 0
+    · simp only [hb, zero_mul, le_refl]
+    · rw [SPMF.probOutput_eq_apply] at hb
+      apply mul_le_mul' le_rfl
+      rw [tsum_probOutput_map_mul]
+      exact expected_exceptionWorldRun_prefixWeight_le parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter _ before.2
+        (exceptionRun_log_cap parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          (adversary.main ⟨root, parameter⟩) state hcap before hb)
+  refine le_trans ?_ hweight
+  apply probEvent_le_tsum_probOutput_mul_cost_of_mem_support
+  intro result _ hflag
+  simp only [prefixHistoryWeight, hflag, ite_true, le_refl]
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessHash.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessHash.lean
new file mode 100644
index 000000000..0a5ec8680
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessHash.lean
@@ -0,0 +1,148 @@
+import SphincsSecurity.Proof.Forced.FtsGuessSigning
+import SphincsSecurity.Proof.Forced.SecretGuessErasure
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open FtsProbeSimulation (decodeProbe? decodeProbe?_eq_some_iff decodeProbe?_eq_none_iff)
+open FtsGuessSigning (Coordinate)
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+
+def coordinate (probe : FtsSecretProbe) : Coordinate := (probe.index, probe.tree, probe.leafIdx)
+
+theorem probe_canonical_iff (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (labels : CanonicalGraphLabels) (probe : FtsSecretProbe) :
+    probe.input parameter = canonicalGraphInput parameter otsSecret ftsSecret (.ftsLeaf probe.index probe.tree probe.leafIdx) labels ↔
+      ftsSecret probe.index probe.tree probe.leafIdx = probe.candidate := by
+  simp only [FtsSecretProbe.input, canonicalGraphInput, canonicalGraphSlots, Position.domain,
+    List.flatMap_cons, List.flatMap_nil, List.append_nil]
+  constructor
+  · intro h
+    exact (digestBytes_injective (tweakableHashInput_injective parameter (by trivial) (by trivial) h).2).symm
+  · intro h
+    rw [h]
+
+theorem programmedHash_probe (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (labels : CanonicalGraphLabels)
+    (residual : QueryImpl HashSpec Id) (probe : FtsSecretProbe) :
+    programmedHash parameter otsSecret ftsSecret labels residual (probe.input parameter) =
+      if ftsSecret probe.index probe.tree probe.leafIdx = probe.candidate then labels (.ftsLeaf probe.index probe.tree probe.leafIdx)
+      else residual (probe.input parameter) := by
+  have hd : decodePosition parameter (probe.input parameter) = some (.ftsLeaf probe.index probe.tree probe.leafIdx) :=
+    (decodePosition_some_iff _ _ _).mpr ⟨digestBytes probe.candidate, rfl⟩
+  rw [programmedHash, hd, Option.elim_some]
+  by_cases hh : ftsSecret probe.index probe.tree probe.leafIdx = probe.candidate
+  · rw [if_pos ((probe_canonical_iff parameter otsSecret ftsSecret labels probe).mpr hh), if_pos hh]
+  · rw [if_neg ((probe_canonical_iff parameter otsSecret ftsSecret labels probe).not.mpr hh), if_neg hh]
+
+theorem programmedHash_nonprobe (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (left right : Index → FtsTree → FtsLeaf → Digest) (labels : CanonicalGraphLabels)
+    (residual : QueryImpl HashSpec Id) (input : HashInput) (hn : decodeProbe? parameter input = none) :
+    programmedHash parameter otsSecret left labels residual input = programmedHash parameter otsSecret right labels residual input := by
+  have hn := (decodeProbe?_eq_none_iff parameter input).mp hn
+  rw [programmedHash, programmedHash]
+  cases hd : decodePosition parameter input with
+  | none => rfl
+  | some position =>
+      simp only [Option.elim_some]
+      cases position <;> try rfl
+      case ftsLeaf index tree leaf =>
+        have hne (secrets : Index → FtsTree → FtsLeaf → Digest) :
+            input ≠ canonicalGraphInput parameter otsSecret secrets (.ftsLeaf index tree leaf) labels := by
+          intro he
+          apply hn ⟨index, tree, leaf, secrets index tree leaf⟩
+          simpa only [canonicalGraphInput, canonicalGraphSlots, Position.domain, List.flatMap_cons,
+            List.flatMap_nil, List.append_nil, FtsSecretProbe.input] using he.symm
+        rw [if_neg (hne left), if_neg (hne right)]
+
+noncomputable def auxiliaryHash (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (labels : CanonicalGraphLabels) (residual : QueryImpl HashSpec Id) : QueryImpl HashSpec Id :=
+  fun input => match decodeProbe? parameter input with
+  | none => programmedHash parameter otsSecret (fun _ _ _ => 0) labels residual input
+  | some _ => residual input
+
+abbrev SigningRecordSpec := Message →ₒ PublicSigningRecord
+abbrev Auxiliary := OracleWorld + SigningRecordSpec
+abbrev World := SecretGuessObservation.World Auxiliary Coordinate Digest
+
+noncomputable def hashProgram (parameter : PublicParameter) (labels : CanonicalGraphLabels) (input : HashInput) :
+    OracleComp World HashOutput :=
+  match decodeProbe? parameter input with
+  | none => liftM (World.query (.inl (.inl (.inr input))))
+  | some probe => do
+      let hit : Bool ← liftM (World.query (.inr (.inl (coordinate probe, probe.candidate))))
+      if hit then pure (labels (.ftsLeaf probe.index probe.tree probe.leafIdx))
+      else liftM (World.query (.inl (.inl (.inr input))))
+
+noncomputable def worldProgram (parameter : PublicParameter) (labels : CanonicalGraphLabels) :
+    QueryImpl OracleWorld (OracleComp World)
+  | .inl input => liftM (World.query (.inl (.inl (.inl input))))
+  | .inr input => hashProgram parameter labels input
+
+noncomputable abbrev fixedAnswers (auxiliary : QueryImpl Auxiliary ProbComp) (secrets : Coordinate → Digest) :
+    QueryImpl World ProbComp := SecretGuessObservation.fixedAnswers auxiliary secrets
+
+noncomputable def auxiliaryAnswers (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (labels : CanonicalGraphLabels) (residual : QueryImpl HashSpec Id)
+    (signer : QueryImpl SigningRecordSpec ProbComp) : QueryImpl Auxiliary ProbComp
+  | .inl input => fixedHashWorld (auxiliaryHash parameter otsSecret labels residual) input
+  | .inr message => signer message
+
+theorem fixed_hashProgram (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (labels : CanonicalGraphLabels) (residual : QueryImpl HashSpec Id)
+    (signer : QueryImpl SigningRecordSpec ProbComp) (input : HashInput) :
+    simulateQ (fixedAnswers (auxiliaryAnswers parameter otsSecret labels residual signer)
+      (FtsGuessSigning.secretTable ftsSecret)) (hashProgram parameter labels input) =
+      pure (programmedHash parameter otsSecret ftsSecret labels residual input) := by
+  cases hd : decodeProbe? parameter input with
+  | none =>
+      simp only [hashProgram, hd, simulateQ_spec_query, fixedAnswers, SecretGuessObservation.fixedAnswers,
+        auxiliaryAnswers, fixedHashWorld, auxiliaryHash]
+      rw [programmedHash_nonprobe parameter otsSecret (fun _ _ _ => 0) ftsSecret labels residual input hd]
+  | some probe =>
+      have hi := (decodeProbe?_eq_some_iff parameter input probe).mp hd
+      rw [hashProgram, hd, simulateQ_bind, simulateQ_spec_query]
+      simp only [fixedAnswers, SecretGuessObservation.fixedAnswers, pure_bind, FtsGuessSigning.secretTable, Equiv.coe_fn_mk, coordinate]
+      split
+      · rename_i hh
+        simp only [decide_eq_true_eq] at hh
+        rw [simulateQ_pure, ← hi, programmedHash_probe, if_pos hh]
+      · rename_i hh
+        have hn : ftsSecret probe.index probe.tree probe.leafIdx ≠ probe.candidate := by simpa only [decide_eq_true_eq] using hh
+        rw [simulateQ_spec_query]
+        simp only [SecretGuessObservation.fixedAnswers, auxiliaryAnswers, fixedHashWorld, auxiliaryHash, hd]
+        rw [← hi, programmedHash_probe, if_neg hn]
+
+theorem fixed_worldProgram (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (labels : CanonicalGraphLabels) (residual : QueryImpl HashSpec Id)
+    (signer : QueryImpl SigningRecordSpec ProbComp) (input : OracleWorld.Domain) :
+    simulateQ (fixedAnswers (auxiliaryAnswers parameter otsSecret labels residual signer)
+      (FtsGuessSigning.secretTable ftsSecret)) (worldProgram parameter labels input) =
+      fixedHashWorld (programmedHash parameter otsSecret ftsSecret labels residual) input := by
+  cases input with
+  | inl input => rfl
+  | inr input => exact fixed_hashProgram parameter otsSecret ftsSecret labels residual signer input
+
+theorem fixed_world_translate {Result : Type} (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (labels : CanonicalGraphLabels) (residual : QueryImpl HashSpec Id)
+    (signer : QueryImpl SigningRecordSpec ProbComp) (computation : OracleComp OracleWorld Result) :
+    simulateQ (fixedAnswers (auxiliaryAnswers parameter otsSecret labels residual signer)
+      (FtsGuessSigning.secretTable ftsSecret)) (simulateQ (worldProgram parameter labels) computation) =
+      simulateQ (fixedHashWorld (programmedHash parameter otsSecret ftsSecret labels residual)) computation := by
+  rw [← QueryImpl.simulateQ_compose]
+  have hi : (fixedAnswers (auxiliaryAnswers parameter otsSecret labels residual signer)
+      (FtsGuessSigning.secretTable ftsSecret)).compose (worldProgram parameter labels) =
+      fixedHashWorld (programmedHash parameter otsSecret ftsSecret labels residual) := by
+    funext input
+    exact fixed_worldProgram parameter otsSecret ftsSecret labels residual signer input
+  rw [hi]
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessInputCoverage.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessInputCoverage.lean
new file mode 100644
index 000000000..e672e5e45
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessInputCoverage.lean
@@ -0,0 +1,461 @@
+import SphincsSecurity.Proof.Forced.FtsGuessCachedSigning
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec UniformTableCompletion
+open FtsGuessSigning (Coordinate)
+open FtsProbeSimulation (retainedGameRestComputation signingTraceComputation liftOracleWorldLeft)
+open SecretGuessObservation (State lazyRun forcedRun environment)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  publicDigestLoop canonicalGraphRoot canonicalGraphInput instSampleableTypePublicParameter hashInputs
+
+/-! ### Hash inputs of continuations -/
+
+theorem hashInputs_bind_of_mem_support {A B : Type} (first : OracleComp OracleWorld A)
+    (next : A → OracleComp OracleWorld B) (value : A) (hvalue : value ∈ support first) :
+    hashInputs (next value) ⊆ hashInputs (first >>= next) := by
+  induction first using OracleComp.inductionOn generalizing next with
+  | pure x =>
+      rw [support_pure, Set.mem_singleton_iff] at hvalue
+      subst hvalue
+      rw [pure_bind]
+  | query_bind input tail ih =>
+      rw [mem_support_bind_iff] at hvalue
+      obtain ⟨answer, _, hvalue⟩ := hvalue
+      rw [bind_assoc]
+      exact (ih answer next hvalue).trans (hashInputs_next_subset input (fun answer => tail answer >>= next) answer)
+
+theorem hashInputs_liftHash_bind_subset {A B : Type} (computation : OracleComp HashSpec A)
+    (next : A → OracleComp OracleWorld B) (value : A) (hvalue : value ∈ support computation) :
+    hashInputs (next value) ⊆ hashInputs ((liftM computation : OracleComp OracleWorld A) >>= next) := by
+  induction computation using OracleComp.inductionOn generalizing next with
+  | pure x =>
+      rw [support_pure, Set.mem_singleton_iff] at hvalue
+      subst hvalue
+      rw [liftM_pure, pure_bind]
+  | query_bind input tail ih =>
+      rw [mem_support_bind_iff] at hvalue
+      obtain ⟨answer, _, hvalue⟩ := hvalue
+      rw [liftM_bind, bind_assoc]
+      change hashInputs (next value) ⊆
+        hashInputs (liftM (OracleWorld.query (.inr input)) >>= fun answer => (liftM (tail answer) : OracleComp OracleWorld A) >>= next)
+      exact (ih answer next hvalue).trans
+        (hashInputs_next_subset (.inr input) (fun answer => (liftM (tail answer) : OracleComp OracleWorld A) >>= next) answer)
+
+theorem hashInputs_liftProb_bind_subset {A B : Type} (computation : ProbComp A)
+    (next : A → OracleComp OracleWorld B) (value : A) (hvalue : value ∈ support computation) :
+    hashInputs (next value) ⊆ hashInputs ((liftM computation : OracleComp OracleWorld A) >>= next) := by
+  induction computation using OracleComp.inductionOn generalizing next with
+  | pure x =>
+      rw [support_pure, Set.mem_singleton_iff] at hvalue
+      subst hvalue
+      rw [liftM_pure, pure_bind]
+  | query_bind input tail ih =>
+      rw [mem_support_bind_iff] at hvalue
+      obtain ⟨answer, _, hvalue⟩ := hvalue
+      rw [liftM_bind, bind_assoc]
+      change hashInputs (next value) ⊆
+        hashInputs (liftM (OracleWorld.query (.inl input)) >>= fun answer => (liftM (tail answer) : OracleComp OracleWorld A) >>= next)
+      exact (ih answer next hvalue).trans
+        (hashInputs_next_subset (.inl input) (fun answer => (liftM (tail answer) : OracleComp OracleWorld A) >>= next) answer)
+
+/-- Evaluating a hash-only computation against a total answer function lands in its support. -/
+theorem evalWithAnswerFn_mem_support {A : Type} (f : QueryImpl HashSpec Id) (computation : OracleComp HashSpec A) :
+    evalWithAnswerFn f computation ∈ support computation := by
+  have hagrees : (∅ : QueryCache HashSpec).AgreesWithFn f := by
+    intro input output houtput
+    simp at houtput
+  obtain ⟨cache, hcache⟩ := (exists_agreesWithFn_evalWithAnswerFn_eq_iff_mem_support computation ∅
+    (evalWithAnswerFn f computation)).mp ⟨f, hagrees, rfl⟩
+  have h : evalWithAnswerFn f computation ∈ support ((simulateQ (randomOracle : QueryImpl HashSpec _) computation).run' ∅) := by
+    rw [StateT.run'_eq, support_map]
+    exact ⟨_, hcache, rfl⟩
+  exact support_simulateQ_run'_subset _ computation ∅ h
+
+theorem evalWithAnswerFn_tweakableHash (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (domain : HashDomain)
+    (payload : HashInput) :
+    evalWithAnswerFn f (tweakableHash parameter domain payload : OracleComp HashSpec Digest) =
+      truncateHash (f (tweakableHashInput parameter domain payload)) := by
+  simp [tweakableHash, oracleHash, evalWithAnswerFn]
+  rfl
+
+/-- Every digest is a possible tree root. -/
+theorem mem_support_treeRoot (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex)
+    (secret : LeafIndex → ChainIndex → Digest) (hheight : 0 < layerHeight lay) (root : Digest) :
+    root ∈ support (treeRoot parameter lay tree secret : OracleComp HashSpec Digest) := by
+  obtain ⟨level, hlevel⟩ := Nat.exists_eq_succ_of_ne_zero (Nat.pos_iff_ne_zero.mp hheight)
+  have hroot : root = evalWithAnswerFn ((fun _ => OtsProbeSimulation.hashOutputOfDigest root) : QueryImpl HashSpec Id)
+      (treeRoot parameter lay tree secret : OracleComp HashSpec Digest) := by
+    rw [treeRoot, hlevel, treeNode_succ_eq, evalWithAnswerFn_bind, evalWithAnswerFn_bind, evalWithAnswerFn_tweakableHash,
+      OtsProbeSimulation.truncateHash_hashOutputOfDigest]
+  rw [hroot]
+  exact evalWithAnswerFn_mem_support _ _
+
+/-! ### Covered inputs of the adversary's remaining computation -/
+
+theorem hashInputs_bind_congr {A B C : Type} (first : OracleComp OracleWorld A) (left : A → OracleComp OracleWorld B)
+    (right : A → OracleComp OracleWorld C) (hnext : ∀ value, hashInputs (left value) = hashInputs (right value)) :
+    hashInputs (first >>= left) = hashInputs (first >>= right) := by
+  induction first using OracleComp.inductionOn with
+  | pure value => simpa only [pure_bind] using hnext value
+  | query_bind input tail ih =>
+      simp only [bind_assoc, hashInputs_query_bind, ih]
+      cases input <;> rfl
+
+theorem signingTrace_bind_fst {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Forgery)
+    (next : Forgery → OracleComp (OracleWorld + SigningSpec) Result) :
+    (signingTraceComputation computation >>= fun result => next result.1) = computation >>= next := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => simp only [FtsProbeSimulation.signingTraceComputation, OracleComp.construct_pure, pure_bind]
+  | query_bind input tail ih =>
+      simp only [FtsProbeSimulation.signingTraceComputation_query_bind, bind_assoc, bind_map_left, ih]
+
+theorem logged_eq_signingTrace {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result) :
+    OtsPrefix.logged computation = signingTraceComputation computation := by
+  rw [OtsPrefix.logged, FtsProbeSimulation.simulateQ_withTraceAppend_run_eq_signingTraceComputation, simulateQ_id']
+
+noncomputable def coveredInputs (key : SecretKey) (computation : OracleComp (OracleWorld + SigningSpec) Forgery) : Finset HashInput :=
+  hashInputs (simulateQ (expandedAdversaryImpl key) (computation >>= fun forgery =>
+    liftOracleWorldLeft (scheme.verify ⟨key.root, key.parameter⟩ forgery.message forgery.signature)))
+
+theorem coveredInputs_main_eq_gameRest (adversary : Adversary) (key : SecretKey) :
+    coveredInputs key (adversary.main ⟨key.root, key.parameter⟩) =
+      hashInputs (gameRest scheme adversary ⟨key.root, key.parameter⟩ key) := by
+  have hretained : OtsProbeSimulation.retainedGameRestComputation adversary ⟨key.root, key.parameter⟩ =
+      retainedGameRestComputation adversary ⟨key.root, key.parameter⟩ := by
+    unfold OtsProbeSimulation.retainedGameRestComputation retainedGameRestComputation
+    rfl
+  have htail : retainedGameRestComputation adversary ⟨key.root, key.parameter⟩ =
+      signingTraceComputation (adversary.main ⟨key.root, key.parameter⟩) >>= fun result =>
+        liftOracleWorldLeft (scheme.verify ⟨key.root, key.parameter⟩ result.1.message result.1.signature) >>= fun verified =>
+          pure (result, verified) := by
+    unfold retainedGameRestComputation
+    apply congrArg (_ >>= ·)
+    funext result
+    rcases result with ⟨forgery, log⟩
+    rfl
+  have hdrop : hashInputs (simulateQ (expandedAdversaryImpl key) (signingTraceComputation (adversary.main ⟨key.root, key.parameter⟩)) >>=
+      fun result => simulateQ (expandedAdversaryImpl key)
+        (liftOracleWorldLeft (scheme.verify ⟨key.root, key.parameter⟩ result.1.message result.1.signature) >>= fun verified =>
+          pure (result, verified))) =
+      hashInputs (simulateQ (expandedAdversaryImpl key) (signingTraceComputation (adversary.main ⟨key.root, key.parameter⟩)) >>=
+        fun result => simulateQ (expandedAdversaryImpl key)
+          (liftOracleWorldLeft (scheme.verify ⟨key.root, key.parameter⟩ result.1.message result.1.signature))) := by
+    refine hashInputs_bind_congr (simulateQ (expandedAdversaryImpl key) (signingTraceComputation (adversary.main ⟨key.root, key.parameter⟩)))
+      (fun result => simulateQ (expandedAdversaryImpl key)
+        (liftOracleWorldLeft (scheme.verify ⟨key.root, key.parameter⟩ result.1.message result.1.signature) >>= fun verified =>
+          pure (result, verified)))
+      (fun result => simulateQ (expandedAdversaryImpl key)
+        (liftOracleWorldLeft (scheme.verify ⟨key.root, key.parameter⟩ result.1.message result.1.signature))) (fun result => ?_)
+    rw [simulateQ_bind]
+    exact ResidualByteFrontend.hashInputs_bind_pure_next _ _ (fun verified => ⟨_, by rw [simulateQ_pure]⟩)
+  have hfst : (signingTraceComputation (adversary.main ⟨key.root, key.parameter⟩) >>= fun result =>
+      liftOracleWorldLeft (scheme.verify ⟨key.root, key.parameter⟩ result.1.message result.1.signature)) =
+      adversary.main ⟨key.root, key.parameter⟩ >>= fun forgery =>
+        liftOracleWorldLeft (scheme.verify ⟨key.root, key.parameter⟩ forgery.message forgery.signature) :=
+    signingTrace_bind_fst _ (fun forgery => liftOracleWorldLeft (scheme.verify ⟨key.root, key.parameter⟩ forgery.message forgery.signature))
+  rw [OtsProbeSimulation.gameRest_eq_map_retained, ResidualByteFrontend.hashInputs_map, hretained, htail, simulateQ_bind, hdrop,
+    ← simulateQ_bind, hfst, coveredInputs]
+
+theorem hashInputs_gameRest_subset_gameAfterSecrets (adversary : Adversary) (parameter : PublicParameter) (root : Digest)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) :
+    hashInputs (gameRest scheme adversary ⟨root, parameter⟩ ⟨parameter, root, otsSecret, ftsSecret⟩) ⊆
+      hashInputs (gameAfterSecrets adversary parameter otsSecret ftsSecret) := by
+  rw [gameAfterSecrets]
+  have hheight : 0 < layerHeight topLayer := by
+    rw [show layerHeight topLayer = maxLayerHeight from rfl]
+    decide
+  exact hashInputs_liftHash_bind_subset (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))
+    (fun root => gameRest scheme adversary ⟨root, parameter⟩ ⟨parameter, root, otsSecret, ftsSecret⟩) root
+    (mem_support_treeRoot parameter topLayer rootTree _ hheight root)
+
+theorem hashInputs_gameAfterSecrets_subset_boundaryGameCore (adversary : Adversary) (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest) :
+    hashInputs (gameAfterSecrets adversary parameter otsSecret ftsSecret) ⊆ hashInputs (boundaryGameCore adversary) := by
+  rw [boundaryGameCore, ← ResidualByteFrontend.hashInputs_boundary parameter (gameAfterSecrets adversary parameter otsSecret ftsSecret)]
+  refine (hashInputs_liftProb_bind_subset sampleFtsSecrets
+    (fun ftsSecret => boundaryComputation parameter (gameAfterSecrets adversary parameter otsSecret ftsSecret)) ftsSecret
+    (by simp only [sampleFtsSecrets, support_uniformSample, Set.mem_univ])).trans ?_
+  refine (hashInputs_liftProb_bind_subset sampleOtsSecrets
+    (fun otsSecret => (liftM sampleFtsSecrets : OracleComp OracleWorld _) >>= fun ftsSecret =>
+      boundaryComputation parameter (gameAfterSecrets adversary parameter otsSecret ftsSecret)) otsSecret
+    (by simp only [sampleOtsSecrets, support_uniformSample, Set.mem_univ])).trans ?_
+  exact hashInputs_liftProb_bind_subset sampleParameter
+    (fun parameter => (liftM sampleOtsSecrets : OracleComp OracleWorld _) >>= fun otsSecret =>
+      (liftM sampleFtsSecrets : OracleComp OracleWorld _) >>= fun ftsSecret =>
+        boundaryComputation parameter (gameAfterSecrets adversary parameter otsSecret ftsSecret)) parameter
+    (by unfold sampleParameter; exact @mem_support_uniformSample PublicParameter instSampleableTypePublicParameter parameter)
+
+theorem hashInputs_gameRest_subset_boundaryGameCore (adversary : Adversary) (key : SecretKey) :
+    hashInputs (gameRest scheme adversary ⟨key.root, key.parameter⟩ key) ⊆ hashInputs (boundaryGameCore adversary) :=
+  (hashInputs_gameRest_subset_gameAfterSecrets adversary key.parameter key.root key.otsSecret key.ftsSecret).trans
+    (hashInputs_gameAfterSecrets_subset_boundaryGameCore adversary key.parameter key.otsSecret key.ftsSecret)
+
+theorem coveredInputs_main_subset (adversary : Adversary) (key : SecretKey) :
+    coveredInputs key (adversary.main ⟨key.root, key.parameter⟩) ⊆ canonicalGraphGameInputs adversary := by
+  rw [coveredInputs_main_eq_gameRest]
+  exact (hashInputs_gameRest_subset_boundaryGameCore adversary key).trans (hashInputs_subset_canonicalGraphGameInputs adversary)
+
+theorem expandedAdversaryImpl_inl (key : SecretKey) (input : OracleWorld.Domain) :
+    expandedAdversaryImpl key (.inl input) = liftM (OracleWorld.query input) := rfl
+
+theorem expandedAdversaryImpl_inr (key : SecretKey) (message : Message) :
+    expandedAdversaryImpl key (.inr message) = sign key message := rfl
+
+theorem coveredInputs_query_bind (key : SecretKey) (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Forgery) :
+    coveredInputs key (liftM ((OracleWorld + SigningSpec).query input) >>= next) =
+      hashInputs (expandedAdversaryImpl key input >>= fun answer => simulateQ (expandedAdversaryImpl key) (next answer >>= fun forgery =>
+        liftOracleWorldLeft (scheme.verify ⟨key.root, key.parameter⟩ forgery.message forgery.signature))) := by
+  unfold coveredInputs
+  rw [bind_assoc, simulateQ_bind, simulateQ_spec_query]
+
+theorem coveredInputs_world (key : SecretKey) (input : HashInput)
+    (next : HashOutput → OracleComp (OracleWorld + SigningSpec) Forgery) :
+    input ∈ coveredInputs key (liftM ((OracleWorld + SigningSpec).query (.inl (.inr input))) >>= next) := by
+  rw [coveredInputs_query_bind, expandedAdversaryImpl_inl]
+  exact mem_hashInputs_hash_bind input _
+
+theorem coveredInputs_world_next (key : SecretKey) (input : OracleWorld.Domain)
+    (next : OracleWorld.Range input → OracleComp (OracleWorld + SigningSpec) Forgery) (answer : OracleWorld.Range input) :
+    coveredInputs key (next answer) ⊆ coveredInputs key (liftM ((OracleWorld + SigningSpec).query (.inl input)) >>= next) := by
+  rw [coveredInputs_query_bind, expandedAdversaryImpl_inl]
+  exact hashInputs_next_subset input (fun answer => simulateQ (expandedAdversaryImpl key) (next answer >>= fun forgery =>
+    liftOracleWorldLeft (scheme.verify ⟨key.root, key.parameter⟩ forgery.message forgery.signature))) answer
+
+theorem coveredInputs_sign (key : SecretKey) (message : Message)
+    (next : Option Signature → OracleComp (OracleWorld + SigningSpec) Forgery) :
+    hashInputs (signDigestLoop digestAttemptLimit key message) ⊆
+      coveredInputs key (liftM ((OracleWorld + SigningSpec).query (.inr message)) >>= next) := by
+  rw [coveredInputs_query_bind, expandedAdversaryImpl_inr]
+  refine Finset.Subset.trans ?_ (ResidualByteFrontend.hashInputs_left_subset _ _)
+  rw [sign_eq_digestLoop_afterDigest]
+  exact ResidualByteFrontend.hashInputs_left_subset _ _
+
+theorem coveredInputs_sign_next (key : SecretKey) (message : Message)
+    (next : Option Signature → OracleComp (OracleWorld + SigningSpec) Forgery)
+    (signature : Option Signature) (hsignature : signature ∈ support (sign key message)) :
+    coveredInputs key (next signature) ⊆ coveredInputs key (liftM ((OracleWorld + SigningSpec).query (.inr message)) >>= next) := by
+  rw [coveredInputs_query_bind, expandedAdversaryImpl_inr]
+  exact hashInputs_bind_of_mem_support (sign key message)
+    (fun answer => simulateQ (expandedAdversaryImpl key) (next answer >>= fun forgery =>
+      liftOracleWorldLeft (scheme.verify ⟨key.root, key.parameter⟩ forgery.message forgery.signature))) signature hsignature
+
+theorem simulateQ_expanded_liftOracleWorldLeft {Result : Type} (key : SecretKey) (computation : OracleComp OracleWorld Result) :
+    simulateQ (expandedAdversaryImpl key) (liftOracleWorldLeft computation) = computation := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => rfl
+  | query_bind input next ih =>
+      rw [FtsProbeSimulation.liftOracleWorldLeft_query_bind, simulateQ_bind, simulateQ_spec_query]
+      simp only [ih]
+      rfl
+
+theorem coveredInputs_pure (key : SecretKey) (forgery : Forgery) :
+    coveredInputs key (pure forgery) = hashInputs (scheme.verify ⟨key.root, key.parameter⟩ forgery.message forgery.signature) := by
+  rw [coveredInputs, pure_bind, simulateQ_expanded_liftOracleWorldLeft]
+
+/-! ### Candidate sets only shrink -/
+
+variable (parameter : PublicParameter) (root : Digest)
+  (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+  (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+  (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (dummy : OtsReferenceWords) (slot : Nat)
+
+theorem cachedForcedRun_allowed_subset {Result : Type} (computation : OracleComp World Result)
+    (cache : QueryCache HashSpec) (state : State Coordinate Digest PUnit) (result : Result × CachedState)
+    (hr : cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot computation (cache, state) result ≠ 0) :
+    ∀ coordinate, result.2.2.allowed coordinate ⊆ state.allowed coordinate := by
+  obtain ⟨seed, _, hforced⟩ := cachedForcedRun_fixed_seed parameter root otsSecret labels inputs hencoding selections rows dummy slot
+    computation cache state result hr
+  have hlazy := SecretGuessObservation.forcedRun_nonzero _ slot _ _ _ hforced
+  apply SecretGuessObservation.lazyRun_preserves _ (fun current : State Coordinate Digest PUnit =>
+    ∀ coordinate, current.allowed coordinate ⊆ state.allowed coordinate) _ computation state (fun _ => Finset.Subset.refl _) _ hlazy
+  intro current hcurrent input step hstep coordinate
+  cases input with
+  | inl input =>
+      simp only [SecretGuessObservation.lazyImpl, StateT.run_mk, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero,
+        Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hstep
+      obtain ⟨answer, _, rfl⟩ := hstep
+      exact hcurrent coordinate
+  | inr input =>
+      cases input with
+      | inl probe =>
+          rcases probe with ⟨probed, candidate⟩
+          simp only [SecretGuessObservation.lazyImpl, StateT.run_mk, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero,
+            Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hstep
+          obtain ⟨hit, _, rfl⟩ := hstep
+          exact (SecretGuessObservation.restrict_subset current.allowed probed candidate hit coordinate).trans (hcurrent coordinate)
+      | inr disclosed =>
+          simp only [SecretGuessObservation.lazyImpl, StateT.run_mk, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero,
+            Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hstep
+          obtain ⟨value, hvalue, rfl⟩ := hstep
+          have hvalue' : cell (Value := Digest) (current.allowed disclosed) value ≠ 0 := hvalue
+          have hmem : (value : Digest) ∈ current.allowed disclosed := by
+            rw [cell_apply] at hvalue'
+            by_contra hnot
+            exact hvalue' (if_neg hnot)
+          show Function.update current.allowed disclosed ({(value : Digest)} : Finset Digest) coordinate ⊆ state.allowed coordinate
+          by_cases heq : coordinate = disclosed
+          · subst heq
+            rw [Function.update_self]
+            exact (Finset.singleton_subset_iff.mpr hmem).trans (hcurrent coordinate)
+          · rw [Function.update_of_ne heq]
+            exact hcurrent coordinate
+
+/-! ### Signatures of the cached forced law are possible signer outputs -/
+
+theorem support_simulateQ_fixedHashWorld_subset {Result : Type} (f : QueryImpl HashSpec Id)
+    (computation : OracleComp OracleWorld Result) :
+    support (simulateQ (fixedHashWorld f) computation) ⊆ support computation := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => simp
+  | query_bind input next ih =>
+      rw [simulateQ_bind, simulateQ_spec_query]
+      intro value hvalue
+      rw [mem_support_bind_iff] at hvalue
+      obtain ⟨answer, _, hvalue⟩ := hvalue
+      rw [mem_support_bind_iff]
+      exact ⟨answer, mem_support_query input answer, ih answer hvalue⟩
+
+theorem mem_support_of_fixedBoundaryRun {Result : Type} (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (computation : OracleComp OracleWorld Result) (result : Result × SigningBoundaryTrace)
+    (hresult : result ∈ support (fixedBoundaryRun parameter f computation)) : result.1 ∈ support computation := by
+  rw [fixedBoundaryRun_eq_boundaryComputation] at hresult
+  have h := support_simulateQ_fixedHashWorld_subset f _ hresult
+  have hfst : result.1 ∈ support (Prod.fst <$> boundaryComputation parameter computation) := by
+    rw [support_map]
+    exact ⟨result, h, rfl⟩
+  rwa [boundaryComputation_fst] at hfst
+
+theorem lazyRun_auxiliary_bind {Result : Type} (auxiliary : QueryImpl Auxiliary ProbComp) (input : Auxiliary.Domain)
+    (next : Auxiliary.Range input → OracleComp World Result) (state : State Coordinate Digest PUnit) :
+    lazyRun (environment auxiliary) (liftM (World.query (.inl input)) >>= next) state =
+      (𝒟[auxiliary input] >>= fun answer => lazyRun (environment auxiliary) (next answer) state) := by
+  rw [lazyRun, SecretGuessObservation.runWith_query_bind]
+  simp only [SecretGuessObservation.lazyImpl, environment, StateT.run_mk, evalDist_map, Functor.map_map, bind_map_left]
+  rfl
+
+theorem foldl_disclosure_allowed_of_notMem (auxiliary : QueryImpl Auxiliary ProbComp) (secrets : Coordinate → Digest)
+    (entries : List Coordinate) (state : State Coordinate Digest PUnit) (coordinate : Coordinate) (hnot : coordinate ∉ entries) :
+    (entries.foldl (fun state coordinate => SecretGuessObservation.afterDisclosure (environment auxiliary) state coordinate (secrets coordinate))
+      state).allowed coordinate = state.allowed coordinate := by
+  induction entries generalizing state with
+  | nil => rfl
+  | cons entry entries ih =>
+      rw [List.foldl_cons, ih _ (fun h => hnot (List.mem_cons_of_mem _ h))]
+      have hne : coordinate ≠ entry := fun h => hnot (h ▸ List.mem_cons_self ..)
+      simp only [SecretGuessObservation.afterDisclosure, discloseTableValue, Function.update_of_ne hne]
+
+theorem foldl_disclosure_allowed_of_mem (auxiliary : QueryImpl Auxiliary ProbComp) (secrets : Coordinate → Digest)
+    (entries : List Coordinate) (state : State Coordinate Digest PUnit) (coordinate : Coordinate) (hmem : coordinate ∈ entries) :
+    (entries.foldl (fun state coordinate => SecretGuessObservation.afterDisclosure (environment auxiliary) state coordinate (secrets coordinate))
+      state).allowed coordinate = {secrets coordinate} := by
+  induction entries generalizing state with
+  | nil => cases hmem
+  | cons entry entries ih =>
+      rw [List.foldl_cons]
+      by_cases hin : coordinate ∈ entries
+      · exact ih _ hin
+      · have heq : coordinate = entry := by
+          rcases List.mem_cons.mp hmem with h | h
+          · exact h
+          · exact absurd h hin
+        subst heq
+        rw [foldl_disclosure_allowed_of_notMem auxiliary secrets entries _ coordinate hin]
+        simp only [SecretGuessObservation.afterDisclosure, discloseTableValue, Function.update_self]
+
+theorem completedState_allowed_disclosed (auxiliary : QueryImpl Auxiliary ProbComp) (secrets : Coordinate → Digest)
+    (plan : PublicSigningPlan) (view : FewTimeView) (trace : SigningBoundaryTrace) (state : State Coordinate Digest PUnit)
+    (tree : FtsTree) :
+    (FtsGuessSigning.completedState (environment auxiliary) secrets ((some plan, some view), trace) state).allowed
+      (view.1, tree, view.2 tree) = {secrets (view.1, tree, view.2 tree)} := by
+  simp only [FtsGuessSigning.completedState, SecretGuessObservation.disclosureSequenceState]
+  apply foldl_disclosure_allowed_of_mem
+  rw [List.mem_ofFn]
+  exact ⟨tree, rfl⟩
+
+theorem completePublicSigningRecord_congr (first second : Index → FtsTree → FtsLeaf → Digest) (record : PublicSigningRecord)
+    (hagree : ∀ (plan : PublicSigningPlan) (view : FewTimeView), record.1 = (some plan, some view) →
+      ∀ tree, first view.1 tree (view.2 tree) = second view.1 tree (view.2 tree)) :
+    completePublicSigningRecord first record = completePublicSigningRecord second record := by
+  obtain ⟨⟨plan, view⟩, trace⟩ := record
+  cases plan with
+  | none => cases view <;> rfl
+  | some plan =>
+      cases view with
+      | none => rfl
+      | some view =>
+          simp only [completePublicSigningRecord, Option.map_some]
+          congr 4
+          funext tree
+          exact hagree plan view rfl tree
+
+theorem complete_ne_zero_of_mem (allowed : Coordinate → Finset Digest) (secrets : Coordinate → Digest)
+    (hmem : ∀ coordinate, secrets coordinate ∈ allowed coordinate) : complete allowed secrets ≠ 0 := by
+  rw [complete_apply, if_pos hmem]
+  apply ENNReal.inv_ne_zero.mpr
+  exact ENNReal.natCast_ne_top _
+
+theorem mem_of_complete_ne_zero (allowed : Coordinate → Finset Digest) (secrets : Coordinate → Digest)
+    (hsecrets : complete allowed secrets ≠ 0) : ∀ coordinate, secrets coordinate ∈ allowed coordinate := by
+  rw [complete_apply] at hsecrets
+  by_contra hnot
+  exact hsecrets (if_neg hnot)
+
+/-- A supported signing outcome of the cached forced law is a possible output of the actual signer, for every secret table compatible with the disclosed coordinates. -/
+theorem cachedSigning_mem_support_sign (message : Message) (cache : QueryCache HashSpec)
+    (state : State Coordinate Digest PUnit) (ha : ∀ coordinate, (state.allowed coordinate).Nonempty)
+    (hauxiliary : ∀ seed : inputs → HashOutput, (⟨selections, rows, seed⟩ : ReferenceAuxiliary inputs) ∈ (referenceAuxiliarySample inputs).support)
+    (result : ((Option Signature × Option FewTimeView) × SigningBoundaryTrace) × CachedState)
+    (hr : cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot (signingProgram message) (cache, state) result ≠ 0)
+    (secrets : Coordinate → Digest) (hsecrets : complete result.2.2.allowed secrets ≠ 0) :
+    result.1.1.1 ∈ support (sign ⟨parameter, root, otsSecret, FtsGuessSigning.secretTable.symm secrets⟩ message) := by
+  obtain ⟨seed, _, hforced⟩ := cachedForcedRun_fixed_seed parameter root otsSecret labels inputs hencoding selections rows dummy slot
+    (signingProgram message) cache state result hr
+  have hlazy := SecretGuessObservation.forcedRun_nonzero _ slot _ _ _ hforced
+  have hsigning : lazyRun (environment (referenceAnswers parameter root otsSecret labels inputs hencoding ⟨selections, rows, seed⟩ dummy))
+      (signingProgram message) state =
+      FtsGuessSigning.lazySigningRun (environment (referenceAnswers parameter root otsSecret labels inputs hencoding ⟨selections, rows, seed⟩ dummy))
+        state parameter root (finiteHashAnswer ∅ inputs (knownReferenceResidual parameter inputs hencoding (known otsSecret labels) rows seed))
+        (known otsSecret labels) (referenceFamilyWords selections dummy) selections message := by
+    rw [signingProgram, lazyRun_auxiliary_bind]
+    rfl
+  rw [hsigning, ← FtsGuessSigning.signingRun_erasure _ _ ha, RetainedObservation.bind_nonzero] at hlazy
+  obtain ⟨table, _, hnative⟩ := hlazy
+  simp only [FtsGuessSigning.nativeRun, FtsGuessSigning.fixedRun_completeRecord, RetainedObservation.bind_nonzero,
+    ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hnative
+  obtain ⟨record, hrecord, heq⟩ := hnative
+  have hstate : result.2.2 = FtsGuessSigning.completedState
+      (environment (referenceAnswers parameter root otsSecret labels inputs hencoding ⟨selections, rows, seed⟩ dummy)) table record state :=
+    congrArg Prod.snd heq
+  have hsignature : result.1 = completePublicSigningRecord (fun index tree leaf => table (index, tree, leaf)) record := congrArg Prod.fst heq
+  have hagree : completePublicSigningRecord (fun index tree leaf => secrets (index, tree, leaf)) record =
+      completePublicSigningRecord (fun index tree leaf => table (index, tree, leaf)) record := by
+    apply completePublicSigningRecord_congr
+    intro plan view hrecord tree
+    have hmem := mem_of_complete_ne_zero _ _ hsecrets (view.1, tree, view.2 tree)
+    have hrec : record = ((some plan, some view), record.2) := Prod.ext hrecord rfl
+    rw [hstate, hrec, completedState_allowed_disclosed, Finset.mem_singleton] at hmem
+    exact hmem
+  have hfixed := FtsGuessSigning.nativeRun_original
+    (environment (referenceAnswers parameter root otsSecret labels inputs hencoding ⟨selections, rows, seed⟩ dummy)) state
+    ⟨parameter, root, otsSecret, FtsGuessSigning.secretTable.symm secrets⟩ inputs hencoding labels ⟨selections, rows, seed⟩ (hauxiliary seed)
+    dummy (fun _ _ _ => False) (known otsSecret labels) (known_agrees otsSecret _ labels _) message
+  dsimp only at hfixed
+  have hnonzero : (Prod.fst <$> FtsGuessSigning.nativeRun
+      (environment (referenceAnswers parameter root otsSecret labels inputs hencoding ⟨selections, rows, seed⟩ dummy))
+      (fun coordinate => FtsGuessSigning.secretTable.symm secrets coordinate.1 coordinate.2.1 coordinate.2.2) state parameter root
+      (finiteHashAnswer ∅ inputs (knownReferenceResidual parameter inputs hencoding (known otsSecret labels) rows seed))
+      (known otsSecret labels) (referenceFamilyWords selections dummy) selections message) result.1 ≠ 0 := by
+    rw [FtsGuessSigning.nativeRun_erasure, evalDist_map, hsignature, ← hagree]
+    exact map_nonzero_of _ _ record hrecord
+  rw [hfixed] at hnonzero
+  have hmem := (mem_support_iff_evalDist_apply_ne_zero _ _).mpr hnonzero
+  have hview := mem_support_of_fixedBoundaryRun _ _ _ _ hmem
+  have hsign : result.1.1.1 ∈ support (Prod.fst <$> signWithView ⟨parameter, root, otsSecret, FtsGuessSigning.secretTable.symm secrets⟩ message) := by
+    rw [support_map]
+    exact ⟨_, hview, rfl⟩
+  rwa [signWithView_fst] at hsign
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessMonitoredAccounting.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessMonitoredAccounting.lean
new file mode 100644
index 000000000..564cec8a2
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessMonitoredAccounting.lean
@@ -0,0 +1,420 @@
+import SphincsSecurity.Proof.Forced.FtsGuessProposalCompleted
+import SphincsSecurity.Proof.Residual.RetainedResidualMessagePayment
+import SphincsSecurity.Proof.Residual.RetainedResidualWorkCost
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec UniformTableCompletion OtsContactTrace ENNReal
+open FtsGuessSigning (Coordinate)
+open FtsProbeSimulation (MessageHashInput messageAnswers)
+open SecretGuessObservation (State)
+open RetainedResidual (proposalOfSigningRecord proposalOfWorldResult digestWork digestWork_messageCalls)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  publicDigestLoop canonicalGraphRoot canonicalGraphInput hashInputs UniformTableCompletion.complete signDigestLoop
+
+variable (parameter : PublicParameter) (root : Digest)
+  (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+  (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+  (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (dummy : OtsReferenceWords) (slot : Nat)
+  (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+/-! ### Trace bookkeeping -/
+
+theorem SigningBoundaryTrace.hashCalls_one : SigningBoundaryTrace.hashCalls (1 : SigningBoundaryTrace) = 0 := rfl
+
+theorem SigningBoundaryTrace.hashCalls_of (entry : Option (HashInput × HashOutput)) :
+    SigningBoundaryTrace.hashCalls (FreeMonoid.of entry : SigningBoundaryTrace) = 1 := rfl
+
+theorem digestWork_hashCalls_ge (known : CanonicalProbeRouting.Labels) (words : OtsReferenceWords) (selections : ReferenceFamily)
+    (selected : Option (Randomness × Index × (IndexGroup → FtsLeaf)) × SigningBoundaryTrace) :
+    selected.2.hashCalls ≤ (digestWork known words selections selected).1.2.hashCalls := by
+  rcases selected with ⟨selected, trace⟩
+  cases selected with
+  | none => exact le_rfl
+  | some selected =>
+      simp only [digestWork, SigningBoundaryTrace.hashCalls_mul]
+      exact Nat.le_add_right _ _
+
+theorem romImpl_hash_cached (input : HashInput) (cache : QueryCache HashSpec) (result : HashOutput × QueryCache HashSpec)
+    (hr : 𝒟[(romImpl (.inr input)).run cache] result ≠ 0) : result.2 input = some result.1 := by
+  have hmem : result ∈ support ((romImpl (.inr input)).run cache) := (mem_support_iff_evalDist_apply_ne_zero _ _).mpr hr
+  change result ∈ support ((randomOracle input).run cache) at hmem
+  cases hc : cache input with
+  | some output =>
+      rw [randomOracle, QueryImpl.withCaching_run_some _ hc, mem_support_pure_iff] at hmem
+      subst result
+      exact hc
+  | none =>
+      rw [randomOracle, QueryImpl.withCaching_run_none _ hc, support_map] at hmem
+      obtain ⟨output, _, rfl⟩ := hmem
+      exact QueryCache.cacheQuery_self cache input output
+
+/-! ### The signing law through the boundary run -/
+
+theorem publicSigningWork_boundary_support (known : CanonicalProbeRouting.Labels) (words : OtsReferenceWords) (selections : ReferenceFamily)
+    (message : Message) (cache : QueryCache HashSpec) (result : PublicSigningRecord × QueryCache HashSpec)
+    (hr : 𝒟[(simulateQ romImpl (Prod.fst <$> ResidualByteFrontend.publicSigningWork parameter root known words selections message)).run cache]
+      result ≠ 0) :
+    ∃ boundary ∈ support (boundaryRun parameter (publicDigestLoop parameter root message digestAttemptLimit) cache),
+      result = ((digestWork known words selections boundary.1).1, boundary.2) := by
+  have hmem := (mem_support_iff_evalDist_apply_ne_zero _ _).mpr hr
+  rw [RetainedResidual.publicSigningWork_eq_digestWork, Functor.map_map, simulateQ_map, StateT.run_map, support_map] at hmem
+  obtain ⟨boundary, hboundary, rfl⟩ := hmem
+  refine ⟨boundary, ?_, rfl⟩
+  rw [simulateQ_boundaryComputation] at hboundary
+  exact hboundary
+
+theorem publicSigningWork_hashCalls_min' (key : SecretKey) (hparameter : key.parameter = parameter) (hroot : key.root = root)
+    (known : CanonicalProbeRouting.Labels) (words : OtsReferenceWords) (selections : ReferenceFamily) (message : Message)
+    (cache : QueryCache HashSpec) (result : PublicSigningRecord × QueryCache HashSpec)
+    (hr : 𝒟[(simulateQ romImpl (Prod.fst <$> ResidualByteFrontend.publicSigningWork parameter root known words selections message)).run cache]
+      result ≠ 0) : 28504 ≤ result.1.2.hashCalls := by
+  subst hparameter hroot
+  have hmem := (mem_support_iff_evalDist_apply_ne_zero _ _).mpr hr
+  rw [simulateQ_map, StateT.run_map, support_map] at hmem
+  obtain ⟨full, hfull, rfl⟩ := hmem
+  exact RetainedResidual.publicSigningWork_hashCalls_min key known words selections message cache full hfull
+
+theorem forcedSigning_source (message : Message) (state : MonitoredState) (hvalid : Valid state)
+    (hinputs : hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs)
+    (result : ((Option Signature × Option FewTimeView) × SigningBoundaryTrace) × CachedState)
+    (hresult : forcedSigning parameter root otsSecret labels inputs hencoding selections rows dummy slot message state result ≠ 0) :
+    ∃ raw : PublicSigningRecord × QueryCache HashSpec,
+      𝒟[(simulateQ romImpl (Prod.fst <$> ResidualByteFrontend.publicSigningWork parameter root (known otsSecret labels)
+        (referenceFamilyWords selections dummy) selections message)).run state.1.1] raw ≠ 0 ∧
+      result.1.2 = raw.1.2 ∧ result.2.1 = raw.2 := by
+  rw [forcedSigning, cachedForcedRun_signingProgram' parameter root otsSecret labels inputs hencoding selections rows dummy slot message state.1
+    hvalid hinputs (referenceAnswers parameter root otsSecret labels inputs hencoding ⟨selections, rows, fun _ => 0⟩ dummy),
+    RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨secrets, _, hresult⟩ := hresult
+  obtain ⟨raw, hraw, rfl⟩ := map_nonzero_source' _ _ _ hresult
+  exact ⟨raw, hraw, completePublicSigningRecord_trace _ raw.1, rfl⟩
+
+/-! ### Accounting along a run -/
+
+structure RunAccount (state : MonitoredState) (trace : SigningBoundaryTrace) (entries : QueryLog SigningSpec) (result : MonitoredState) :
+    Prop where
+  cache_le : state.1.1 ≤ result.1.1
+  rows : ∀ row ∈ trace.messageCalls, result.1.1 row.1 = some row.2
+  enncard : QueryCache.enncard result.1.1 ≤ QueryCache.enncard state.1.1 + trace.hashCalls
+  mass : result.2.creationMass ≤ state.2.creationMass + trace.hashCalls
+  alive : result.2.stopped = false → state.2.stopped = false
+  spent : result.2.stopped = false → result.2.spent = state.2.spent + trace.hashCalls
+  log : result.2.stopped = false → result.2.log = state.2.log ++ entries
+  digests : ∀ reference, SigningDigestsCached parameter state.1.1 root reference →
+    SigningDigestsCached parameter result.1.1 root (reference ++ entries)
+  bank : (state.2.stopped = false → CertificateBankComplete (monitorKey parameter root) required (monitorView state)) →
+    result.2.stopped = false → CertificateBankComplete (monitorKey parameter root) required (monitorView result)
+
+theorem RunAccount.refl (state : MonitoredState) : RunAccount parameter root required state 1 [] state where
+  cache_le := le_rfl
+  rows := fun _ hrow => by cases hrow
+  enncard := by rw [SigningBoundaryTrace.hashCalls_one, Nat.cast_zero, add_zero]
+  mass := by rw [SigningBoundaryTrace.hashCalls_one, Nat.cast_zero, add_zero]
+  alive := id
+  spent := fun _ => by rw [SigningBoundaryTrace.hashCalls_one, Nat.add_zero]
+  log := fun _ => by rw [List.append_nil]
+  digests := fun reference h => by rw [List.append_nil]; exact h
+  bank := fun h halive => h halive
+
+theorem RunAccount.trans {first middle last : MonitoredState} {trace tail : SigningBoundaryTrace} {log more : QueryLog SigningSpec}
+    (hfirst : RunAccount parameter root required first trace log middle) (hlast : RunAccount parameter root required middle tail more last) :
+    RunAccount parameter root required first (trace * tail) (log ++ more) last where
+  cache_le := hfirst.cache_le.trans hlast.cache_le
+  rows := by
+    intro row hrow
+    rw [SigningBoundaryTrace.messageCalls_mul, List.mem_append] at hrow
+    rcases hrow with hrow | hrow
+    · exact hlast.cache_le (hfirst.rows row hrow)
+    · exact hlast.rows row hrow
+  enncard := by
+    rw [SigningBoundaryTrace.hashCalls_mul, Nat.cast_add, ← add_assoc]
+    exact hlast.enncard.trans (add_le_add hfirst.enncard le_rfl)
+  mass := by
+    rw [SigningBoundaryTrace.hashCalls_mul, Nat.cast_add, ← add_assoc]
+    exact hlast.mass.trans (add_le_add hfirst.mass le_rfl)
+  alive := fun halive => hfirst.alive (hlast.alive halive)
+  spent := fun halive => by
+    rw [hlast.spent halive, hfirst.spent (hlast.alive halive), SigningBoundaryTrace.hashCalls_mul, Nat.add_assoc]
+  log := fun halive => by
+    rw [hlast.log halive, hfirst.log (hlast.alive halive), List.append_assoc]
+  digests := fun reference h => by
+    rw [← List.append_assoc]
+    exact hlast.digests _ (hfirst.digests reference h)
+  bank := fun h halive => hlast.bank (hfirst.bank h) halive
+
+private theorem update_active_of_alive (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState) (length : Nat)
+    (record : ProposalExecutionRecord input)
+    (halive : (certificateMonitorUpdate (monitorKey parameter root) budget required stopAfter input state length record).stopped = false) :
+    CertificateMonitorActive (monitorKey parameter root) budget input state := by
+  by_contra h
+  rw [certificateMonitorUpdate_inactive (monitorKey parameter root) budget required stopAfter input state length record h] at halive
+  contradiction
+
+private theorem update_alive (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState) (length : Nat)
+    (record : ProposalExecutionRecord input)
+    (halive : (certificateMonitorUpdate (monitorKey parameter root) budget required stopAfter input state length record).stopped = false) :
+    state.2.stopped = false :=
+  (update_active_of_alive parameter root budget required stopAfter input state length record halive).1
+
+private theorem update_mass_le (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState) (length : Nat)
+    (record : ProposalExecutionRecord input) (bound : ENNReal)
+    (hbound : targetCreationMultiplier (monitorKey parameter root) state.1 input ≤ bound) :
+    (certificateMonitorUpdate (monitorKey parameter root) budget required stopAfter input state length record).creationMass ≤
+      state.2.creationMass + bound := by
+  rw [certificateMonitorUpdate_creationMass]
+  apply add_le_add le_rfl
+  by_cases hactive : CertificateMonitorActive (monitorKey parameter root) budget input state
+  · rw [certificateMonitorMass, if_pos hactive]
+    exact hbound
+  · rw [certificateMonitorMass, if_neg hactive]
+    exact zero_le
+
+theorem worldStep_account (input : OracleWorld.Domain) (state : MonitoredState) (hinputs : hashInputs (liftM (OracleWorld.query input)) ⊆ inputs)
+    (raw : OracleWorld.Range input × CachedState)
+    (hraw : cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot (worldProgram parameter labels input)
+      state.1 raw ≠ 0) :
+    RunAccount parameter root required state (signingBoundaryTrace parameter input raw.1) []
+      (raw.2, certificateMonitorUpdate (monitorKey parameter root) budget required stopAfter (.inl input) (monitorView state) 0
+        (proposalOfWorldResult parameter input (raw.1, raw.2.1))) := by
+  have hcache := worldStep_cache_le parameter root otsSecret labels inputs hencoding selections rows dummy slot input state hinputs raw hraw
+  have hmass : targetCreationMultiplier (monitorKey parameter root) state.1.1 (.inl input) ≤
+      ((signingBoundaryTrace parameter input raw.1).hashCalls : ENNReal) := by
+    rw [signingBoundaryTrace_hashCalls_eq, targetCreationMultiplier]
+    cases input with
+    | inl sample => exact le_rfl
+    | inr hash =>
+        simp only [freshWorldTargetHashCost]
+        split_ifs <;> norm_num
+  refine ⟨hcache.1, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩
+  · intro row hrow
+    cases input with
+    | inl sample => cases hrow
+    | inr hash =>
+        by_cases hmessage : MessageHashInput parameter hash
+        · have hlaw := hraw
+          rw [cachedForcedRun_world_message' parameter root otsSecret labels inputs hencoding selections rows dummy slot hash
+            (hinputs (by simpa only [bind_pure] using mem_hashInputs_hash_bind hash pure)) hmessage state.1] at hlaw
+          obtain ⟨source, hsource, heq⟩ := map_nonzero_source' _ _ _ hlaw
+          have hcached := romImpl_hash_cached hash state.1.1 source hsource
+          simp only [signingBoundaryTrace, if_pos hmessage] at hrow
+          change row ∈ [(hash, raw.1)] at hrow
+          obtain rfl := List.mem_singleton.mp hrow
+          rw [heq]
+          exact hcached
+        · simp [signingBoundaryTrace, SigningBoundaryTrace.messageCalls, hmessage] at hrow
+  · cases input with
+    | inl sample =>
+        rw [cachedForcedRun_world_unif'] at hraw
+        obtain ⟨answer, _, rfl⟩ := map_nonzero_source' _ _ _ hraw
+        simp only [signingBoundaryTrace, SigningBoundaryTrace.hashCalls_one, Nat.cast_zero, add_zero]
+        exact le_rfl
+    | inr hash =>
+        simp only [signingBoundaryTrace, SigningBoundaryTrace.hashCalls_of, Nat.cast_one]
+        exact (cachedForcedRun_world_hash_support' parameter root otsSecret labels inputs hencoding selections rows dummy slot hash state.1 raw
+          hraw).2.2
+  · exact update_mass_le parameter root budget required stopAfter (.inl input) (monitorView state) 0 _ _ hmass
+  · exact update_alive parameter root budget required stopAfter (.inl input) (monitorView state) 0 _
+  · intro halive
+    rw [certificateMonitorUpdate_spent (monitorKey parameter root) budget required stopAfter (.inl input) (monitorView state) 0 _
+      (update_active_of_alive parameter root budget required stopAfter (.inl input) (monitorView state) 0 _ halive)]
+    rfl
+  · intro halive
+    rw [certificateMonitorUpdate, if_pos (update_active_of_alive parameter root budget required stopAfter (.inl input) (monitorView state) 0 _
+      halive)]
+    rfl
+  · intro reference hreference
+    rw [List.append_nil]
+    exact worldStep_digestsCached parameter root otsSecret labels inputs hencoding selections rows dummy slot input state hinputs reference
+      hreference raw hraw
+  · intro _ halive
+    exact certificateMonitorUpdate_bank_complete (monitorKey parameter root) budget required stopAfter (.inl input) (monitorView state) 0 _ halive
+
+theorem signStep_account (message : Message) (state : MonitoredState) (hvalid : Valid state)
+    (hinputs : hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs) (annotation : Nat × Index)
+    (raw : ((Option Signature × Option FewTimeView) × SigningBoundaryTrace) × CachedState)
+    (hraw : forcedSigning parameter root otsSecret labels inputs hencoding selections rows dummy slot message state raw ≠ 0) :
+    RunAccount parameter root required state raw.1.2 [⟨message, raw.1.1.1⟩]
+      (raw.2, certificateMonitorUpdate (monitorKey parameter root) budget required stopAfter (.inr message) (monitorView state) annotation.1
+        (proposalOfSigningRecord message raw.1 raw.2.1 (raw.1.1.2.elim annotation.2 Prod.fst))) := by
+  obtain ⟨source, hsource, htrace, hcache⟩ := forcedSigning_source parameter root otsSecret labels inputs hencoding selections rows dummy slot
+    message state hvalid hinputs raw hraw
+  obtain ⟨boundary, hboundary, hsplit⟩ := publicSigningWork_boundary_support parameter root (known otsSecret labels)
+    (referenceFamilyWords selections dummy) selections message state.1.1 source hsource
+  have hmin := publicSigningWork_hashCalls_min' parameter root (monitorKey parameter root) rfl rfl (known otsSecret labels)
+    (referenceFamilyWords selections dummy) selections message state.1.1 source hsource
+  have hcalls : boundary.1.2.hashCalls ≤ raw.1.2.hashCalls := by
+    rw [htrace, hsplit]
+    exact digestWork_hashCalls_ge _ _ _ boundary.1
+  have hrows : raw.1.2.messageCalls = boundary.1.2.messageCalls := by
+    rw [htrace, hsplit]
+    exact digestWork_messageCalls _ _ _ boundary.1
+  have hcachesplit : raw.2.1 = boundary.2 := by rw [hcache, hsplit]
+  have hmass : targetCreationMultiplier (monitorKey parameter root) state.1.1 (.inr message) ≤ (raw.1.2.hashCalls : ENNReal) := by
+    have hp := mul_le_mul' (le_refl (((2 ^ ftsTreeHeight : Nat) : ENNReal)))
+      (freshDigestSelectionProbability_le_one (monitorKey parameter root) message state.1.1)
+    calc
+      _ ≤ ((2 ^ ftsTreeHeight : Nat) : ENNReal) := by simpa only [targetCreationMultiplier, mul_one] using hp
+      _ ≤ (28504 : Nat) := by norm_num [ftsTreeHeight]
+      _ ≤ _ := by
+        rw [htrace]
+        exact Nat.cast_le.mpr hmin
+  refine ⟨forcedSigning_cache_le parameter root otsSecret labels inputs hencoding selections rows dummy slot message state hvalid hinputs raw hraw,
+    ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩
+  · intro row hrow
+    rw [hrows] at hrow
+    change raw.2.1 row.1 = some row.2
+    rw [hcachesplit]
+    exact boundaryRun_message_cached parameter _ state.1.1 boundary hboundary row hrow
+  · change QueryCache.enncard raw.2.1 ≤ _
+    rw [hcachesplit]
+    exact (boundaryRun_enncard_le parameter _ state.1.1 boundary hboundary).trans (add_le_add le_rfl (Nat.cast_le.mpr hcalls))
+  · exact update_mass_le parameter root budget required stopAfter (.inr message) (monitorView state) annotation.1 _ _ hmass
+  · exact update_alive parameter root budget required stopAfter (.inr message) (monitorView state) annotation.1 _
+  · intro halive
+    rw [certificateMonitorUpdate_spent (monitorKey parameter root) budget required stopAfter (.inr message) (monitorView state) annotation.1 _
+      (update_active_of_alive parameter root budget required stopAfter (.inr message) (monitorView state) annotation.1 _ halive)]
+    rfl
+  · intro halive
+    rw [certificateMonitorUpdate, if_pos (update_active_of_alive parameter root budget required stopAfter (.inr message) (monitorView state)
+      annotation.1 _ halive)]
+    rfl
+  · intro reference hreference
+    exact forcedSigning_digestsCached parameter root otsSecret labels inputs hencoding selections rows dummy slot message state hvalid hinputs
+      reference hreference raw hraw
+  · intro _ halive
+    exact certificateMonitorUpdate_bank_complete (monitorKey parameter root) budget required stopAfter (.inr message) (monitorView state)
+      annotation.1 _ halive
+
+theorem monitoredStep_account (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState) (hvalid : Valid state)
+    (hworld : ∀ world, input = .inl world → hashInputs (liftM (OracleWorld.query world)) ⊆ inputs)
+    (hsign : ∀ message, input = .inr message → hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs)
+    (result : AdversaryStep input × MonitoredState)
+    (hresult : monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      input state result ≠ 0) :
+    RunAccount parameter root required state result.1.1.2 (signingLogFragment input result.1.1.1) result.2 := by
+  cases input with
+  | inl input =>
+      rw [monitoredStep, monitoredWorldStep] at hresult
+      obtain ⟨raw, hraw, rfl⟩ := map_nonzero_source' _ _ _ hresult
+      exact worldStep_account parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state
+        (hworld input rfl) raw hraw
+  | inr message =>
+      rw [monitoredStep, monitoredSignStep_eq, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨annotation, _, hresult⟩ := hresult
+      obtain ⟨raw, hraw, rfl⟩ := map_nonzero_source' _ _ _ hresult
+      exact signStep_account parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter message state
+        hvalid (hsign message rfl) annotation raw hraw
+
+variable (hauxiliary : ∀ seed : inputs → HashOutput,
+  (⟨selections, rows, seed⟩ : ReferenceAuxiliary inputs) ∈ (referenceAuxiliarySample inputs).support)
+
+include hauxiliary in
+theorem monitoredRun_account (computation : OracleComp (OracleWorld + SigningSpec) Forgery) (state : MonitoredState) (hvalid : Valid state)
+    (hcovered : CoveredRun parameter root otsSecret inputs computation state) (result : AdversaryTrace × MonitoredState)
+    (hresult : monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      computation state result ≠ 0) :
+    RunAccount parameter root required state result.1.1.2 result.1.1.1.2 result.2 := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      rw [monitoredRun_pure] at hresult
+      simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact RunAccount.refl parameter root required state
+  | query_bind input next ih =>
+      rw [monitoredRun_query_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨step, hstep, hresult⟩ := hresult
+      obtain ⟨tail, htail, rfl⟩ := map_nonzero_source' _ _ _ hresult
+      have hfirst := monitoredStep_account parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        input state hvalid
+        (fun world heq => by subst heq; exact covered_world_inputs parameter root otsSecret inputs world next state hvalid hcovered)
+        (covered_step_digest parameter root otsSecret inputs input next state hvalid hcovered) step hstep
+      have hlast := ih step.1.1.1 step.2
+        (monitoredStep_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state
+          hvalid step hstep)
+        (covered_step_next parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter hauxiliary input
+          next state hvalid hcovered step hstep) tail htail
+      exact RunAccount.trans parameter root required hfirst hlast
+
+theorem monitoredWorldRun_account {Result : Type} (computation : OracleComp OracleWorld Result) (state : MonitoredState) (hvalid : Valid state)
+    (hinputs : hashInputs computation ⊆ inputs) (result : ((Result × SigningBoundaryTrace) × Trace) × MonitoredState)
+    (hresult : monitoredWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      computation state result ≠ 0) :
+    RunAccount parameter root required state result.1.1.2 [] result.2 := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      rw [monitoredWorldRun_pure] at hresult
+      simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact RunAccount.refl parameter root required state
+  | query_bind input next ih =>
+      rw [monitoredWorldRun_query_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨step, hstep, hresult⟩ := hresult
+      obtain ⟨tail, htail, rfl⟩ := map_nonzero_source' _ _ _ hresult
+      have hfirst := monitoredStep_account parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        (.inl input) state hvalid (fun world heq => by cases heq; exact (hashInputs_world_query input next).trans hinputs)
+        (fun message heq => by cases heq) step hstep
+      have hlast := ih step.1.1.1 step.2
+        (monitoredStep_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter (.inl input)
+          state hvalid step hstep) ((hashInputs_world_next input next step.1.1.1).trans hinputs) tail htail
+      simpa only [signingLogFragment, List.nil_append] using RunAccount.trans parameter root required hfirst hlast
+
+include hauxiliary in
+theorem monitoredCompletedRun_account (adversary : Adversary) (state : MonitoredState) (hvalid : Valid state)
+    (hcovered : CoveredRun parameter root otsSecret inputs (adversary.main ⟨root, parameter⟩) state) (result : Completed × MonitoredState)
+    (hresult : monitoredCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      adversary state result ≠ 0) :
+    RunAccount parameter root required state (result.1.1.1.2 * result.1.2.1.2) result.1.1.1.1.2 result.2 := by
+  rw [monitoredCompletedRun_eq, RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨before, hbefore, hresult⟩ := hresult
+  obtain ⟨checked, hchecked, rfl⟩ := map_nonzero_source' _ _ _ hresult
+  have hfirst := monitoredRun_account parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+    hauxiliary (adversary.main ⟨root, parameter⟩) state hvalid hcovered before hbefore
+  have hvalid' := monitoredRun_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+    (adversary.main ⟨root, parameter⟩) state hvalid before hbefore
+  have hfinal := monitoredRun_covered parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+    hauxiliary (adversary.main ⟨root, parameter⟩) state hvalid hcovered before hbefore
+  have hlast := monitoredWorldRun_account parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+    (verifyComputation parameter root before.1.1.1.1) before.2 hvalid'
+    (covered_pure parameter root otsSecret inputs before.1.1.1.1 before.2 hvalid' hfinal) checked hchecked
+  simpa only [List.append_nil] using RunAccount.trans parameter root required hfirst hlast
+
+/-! ### Consequences for the completed run -/
+
+include hauxiliary in
+theorem monitoredCompletedRun_creationMass_le (adversary : Adversary) (spent : Nat) (stopped : Bool)
+    (hcovered : CoveredRun parameter root otsSecret inputs (adversary.main ⟨root, parameter⟩)
+      ((∅, SecretGuessObservation.initialState PUnit.unit), initialCertificateMonitor spent stopped))
+    (result : Completed × MonitoredState)
+    (hresult : monitoredCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      adversary ((∅, SecretGuessObservation.initialState PUnit.unit), initialCertificateMonitor spent stopped) result ≠ 0) :
+    result.2.2.creationMass ≤ (completedWork result.1 : ENNReal) := by
+  have h := (monitoredCompletedRun_account parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+    hauxiliary adversary _ (fun _ => Finset.univ_nonempty) hcovered result hresult).mass
+  simpa only [initialCertificateMonitor, zero_add, SigningBoundaryTrace.hashCalls_mul, completedWork, Nat.cast_add] using h
+
+include hauxiliary in
+theorem monitoredCompletedRun_certificate_count (adversary : Adversary) (spent : Nat) (stopped : Bool)
+    (hcovered : CoveredRun parameter root otsSecret inputs (adversary.main ⟨root, parameter⟩)
+      ((∅, SecretGuessObservation.initialState PUnit.unit), initialCertificateMonitor spent stopped))
+    (result : Completed × MonitoredState)
+    (hresult : monitoredCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      adversary ((∅, SecretGuessObservation.initialState PUnit.unit), initialCertificateMonitor spent stopped) result ≠ 0)
+    (halive : result.2.2.stopped = false) (input : HashInput)
+    (hcertificate : TargetCertificateAt (monitorKey parameter root) required
+      (hashRowsCache (result.1.1.1.2 * result.1.2.1.2).messageCalls, result.1.1.1.1.2) input) :
+    1 ≤ certificateBankCount result.2.2.bank := by
+  have haccount := monitoredCompletedRun_account parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+    stopAfter hauxiliary adversary _ (fun _ => Finset.univ_nonempty) hcovered result hresult
+  have hbank := haccount.bank (fun _ => initialCertificateMonitor_bank_complete (monitorKey parameter root) spent required ∅ stopped
+    (fun _ _ => rfl)) halive
+  have hlog := haccount.log halive
+  simp only [initialCertificateMonitor, List.nil_append] at hlog
+  apply one_le_certificateBankCount _ input
+  apply hbank input
+  change TargetCertificateAt (monitorKey parameter root) required (result.2.1.1, result.2.2.log) input
+  rw [hlog]
+  exact hcertificate.mono (hashRowsCache_le _ _ haccount.rows)
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessMonitoredPayment.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessMonitoredPayment.lean
new file mode 100644
index 000000000..6218555af
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessMonitoredPayment.lean
@@ -0,0 +1,356 @@
+import SphincsSecurity.Proof.Forced.FtsGuessMonitoredPotential
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec UniformTableCompletion OtsContactTrace ENNReal
+open FtsGuessSigning (Coordinate)
+open FtsProbeSimulation (MessageHashInput)
+open SecretGuessObservation (State)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  publicDigestLoop canonicalGraphRoot canonicalGraphInput hashInputs UniformTableCompletion.complete
+
+variable (parameter : PublicParameter) (root : Digest)
+  (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+  (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+  (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (dummy : OtsReferenceWords) (slot : Nat)
+  (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+  (hauxiliary : ∀ seed : inputs → HashOutput,
+    (⟨selections, rows, seed⟩ : ReferenceAuxiliary inputs) ∈ (referenceAuxiliarySample inputs).support)
+
+/-! ### Run-level validity and coverage -/
+
+theorem monitoredRun_valid {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result) (state : MonitoredState)
+    (hvalid : Valid state) (result : (((Result × QueryLog SigningSpec) × SigningBoundaryTrace) × Trace) × MonitoredState)
+    (hresult : monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      computation state result ≠ 0) : Valid result.2 := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      rw [monitoredRun_pure] at hresult
+      simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact hvalid
+  | query_bind input next ih =>
+      rw [monitoredRun_query_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨step, hstep, hresult⟩ := hresult
+      obtain ⟨tail, htail, rfl⟩ := map_nonzero_source' _ _ _ hresult
+      exact ih step.1.1.1 step.2
+        (monitoredStep_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          input state hvalid step hstep) tail htail
+
+include hauxiliary in
+theorem monitoredRun_covered (computation : OracleComp (OracleWorld + SigningSpec) Forgery) (state : MonitoredState)
+    (hvalid : Valid state) (hcovered : CoveredRun parameter root otsSecret inputs computation state)
+    (result : AdversaryTrace × MonitoredState)
+    (hresult : monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      computation state result ≠ 0) : CoveredRun parameter root otsSecret inputs (pure result.1.1.1.1) result.2 := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      rw [monitoredRun_pure] at hresult
+      simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact hcovered
+  | query_bind input next ih =>
+      rw [monitoredRun_query_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨step, hstep, hresult⟩ := hresult
+      obtain ⟨tail, htail, rfl⟩ := map_nonzero_source' _ _ _ hresult
+      exact ih step.1.1.1 step.2
+        (monitoredStep_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          input state hvalid step hstep)
+        (covered_step_next parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter hauxiliary
+          input next state hvalid hcovered step hstep) tail htail
+
+theorem monitoredStep_inl (input : OracleWorld.Domain) (state : MonitoredState) :
+    monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter (.inl input) state =
+      monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state := rfl
+
+/-! ### Creation counters -/
+
+theorem monitoredStep_creation_counters (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState)
+    (result : AdversaryStep input × MonitoredState)
+    (hresult : monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      input state result ≠ 0) :
+    result.2.2.creationCost = state.2.creationCost +
+        certificateMonitorCharge (monitorKey parameter root) budget required input (monitorView state) ∧
+      result.2.2.creationMass = state.2.creationMass + certificateMonitorMass (monitorKey parameter root) budget input (monitorView state) := by
+  cases input with
+  | inl input =>
+      rw [monitoredStep, monitoredWorldStep] at hresult
+      obtain ⟨raw, _, rfl⟩ := map_nonzero_source' _ _ _ hresult
+      exact ⟨certificateMonitorUpdate_creationCost _ _ _ _ _ _ _ _, certificateMonitorUpdate_creationMass _ _ _ _ _ _ _ _⟩
+  | inr message =>
+      rw [monitoredStep, monitoredSignStep, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨annotation, _, hresult⟩ := hresult
+      obtain ⟨raw, _, rfl⟩ := map_nonzero_source' _ _ _ hresult
+      exact ⟨certificateMonitorUpdate_creationCost _ _ _ _ _ _ _ _, certificateMonitorUpdate_creationMass _ _ _ _ _ _ _ _⟩
+
+theorem expected_monitoredStep_creationCost (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState) (hvalid : Valid state) :
+    (∑' result, Pr[= result | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter input state] * result.2.2.creationCost) =
+      state.2.creationCost + certificateMonitorCharge (monitorKey parameter root) budget required input (monitorView state) := by
+  calc
+    _ = ∑' result, Pr[= result | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter input state] *
+        (state.2.creationCost + certificateMonitorCharge (monitorKey parameter root) budget required input (monitorView state)) := by
+      apply tsum_congr
+      intro result
+      by_cases hr : Pr[= result | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter input state] = 0
+      · simp only [hr, zero_mul]
+      · rw [SPMF.probOutput_eq_apply] at hr
+        rw [(monitoredStep_creation_counters parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter input state result hr).1]
+    _ = _ := by
+      rw [ENNReal.tsum_mul_right, tsum_monitoredStep_eq_one parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+        required stopAfter input state hvalid, one_mul]
+
+/-! ### Payment accumulators over the adversary run -/
+
+noncomputable def expectedMonitoredPayment (charge : (OracleWorld + SigningSpec).Domain → CertificateMonitorState → ENNReal)
+    (computation : OracleComp (OracleWorld + SigningSpec) Forgery) : MonitoredState → ENNReal :=
+  OracleComp.construct (fun _ _ => 0) (fun input _ next state =>
+    charge input (monitorView state) +
+      ∑' result, Pr[= result | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter input state] * next result.1.1.1 result.2) computation
+
+theorem expectedMonitoredPayment_query_bind (charge : (OracleWorld + SigningSpec).Domain → CertificateMonitorState → ENNReal)
+    (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Forgery) (state : MonitoredState) :
+    expectedMonitoredPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter charge
+      (liftM ((OracleWorld + SigningSpec).query input) >>= next) state =
+      charge input (monitorView state) +
+        ∑' result, Pr[= result | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter input state] *
+          expectedMonitoredPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter charge
+            (next result.1.1.1) result.2 := rfl
+
+theorem expected_monitoredRun_accumulator (counter : CertificateMonitor → ENNReal)
+    (charge : (OracleWorld + SigningSpec).Domain → CertificateMonitorState → ENNReal)
+    (hstep : ∀ input state, Valid state →
+      (∑' result, Pr[= result | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter input state] * counter result.2.2) = counter state.2 + charge input (monitorView state))
+    (computation : OracleComp (OracleWorld + SigningSpec) Forgery) (state : MonitoredState) (hvalid : Valid state) :
+    (∑' result, Pr[= result | monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter computation state] * counter result.2.2) =
+      counter state.2 +
+        expectedMonitoredPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter charge
+          computation state := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [monitoredRun_pure, tsum_probOutput_pure_mul, expectedMonitoredPayment, construct_pure, add_zero]
+  | query_bind input next ih =>
+      rw [monitoredRun_query_bind, tsum_probOutput_bind_mul, expectedMonitoredPayment_query_bind]
+      calc
+        _ = ∑' result, Pr[= result | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+              stopAfter input state] *
+            (counter result.2.2 +
+              expectedMonitoredPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+                charge (next result.1.1.1) result.2) := by
+          apply tsum_congr
+          intro result
+          by_cases hr : Pr[= result | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+              stopAfter input state] = 0
+          · simp only [hr, zero_mul]
+          · rw [SPMF.probOutput_eq_apply] at hr
+            rw [tsum_probOutput_map_mul]
+            apply congrArg (_ * ·)
+            exact ih result.1.1.1 result.2
+              (monitoredStep_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+                input state hvalid result hr)
+        _ = _ := by
+          simp only [mul_add, ENNReal.tsum_add]
+          rw [hstep input state hvalid, add_assoc]
+
+theorem expected_monitoredRun_creationCost (computation : OracleComp (OracleWorld + SigningSpec) Forgery) (state : MonitoredState)
+    (hvalid : Valid state) :
+    (∑' result, Pr[= result | monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter computation state] * result.2.2.creationCost) =
+      state.2.creationCost +
+        expectedMonitoredCharge parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          computation state :=
+  expected_monitoredRun_accumulator parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+    CertificateMonitor.creationCost (certificateMonitorCharge (monitorKey parameter root) budget required)
+    (fun input state hvalid => expected_monitoredStep_creationCost parameter root otsSecret labels inputs hencoding selections rows dummy slot
+      budget required stopAfter input state hvalid) computation state hvalid
+
+/-! ### Payment accumulators over the verifier -/
+
+noncomputable def expectedWorldPayment (charge : (OracleWorld + SigningSpec).Domain → CertificateMonitorState → ENNReal)
+    {Result : Type} (computation : OracleComp OracleWorld Result) : MonitoredState → ENNReal :=
+  OracleComp.construct (fun _ _ => 0) (fun input _ next state =>
+    charge (.inl input) (monitorView state) +
+      ∑' result, Pr[= result | monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter input state] * next result.1.1.1 result.2) computation
+
+theorem expectedWorldPayment_query_bind (charge : (OracleWorld + SigningSpec).Domain → CertificateMonitorState → ENNReal)
+    {Result : Type} (input : OracleWorld.Domain) (next : OracleWorld.Range input → OracleComp OracleWorld Result) (state : MonitoredState) :
+    expectedWorldPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter charge
+      (liftM (OracleWorld.query input) >>= next) state =
+      charge (.inl input) (monitorView state) +
+        ∑' result, Pr[= result | monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter input state] *
+          expectedWorldPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter charge
+            (next result.1.1.1) result.2 := rfl
+
+theorem expected_monitoredWorldRun_accumulator (counter : CertificateMonitor → ENNReal)
+    (charge : (OracleWorld + SigningSpec).Domain → CertificateMonitorState → ENNReal)
+    (hstep : ∀ input state, Valid state →
+      (∑' result, Pr[= result | monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter input state] * counter result.2.2) = counter state.2 + charge (.inl input) (monitorView state))
+    {Result : Type} (computation : OracleComp OracleWorld Result) (state : MonitoredState) (hvalid : Valid state) :
+    (∑' result, Pr[= result | monitoredWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter computation state] * counter result.2.2) =
+      counter state.2 +
+        expectedWorldPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter charge
+          computation state := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [monitoredWorldRun_pure, tsum_probOutput_pure_mul, expectedWorldPayment, construct_pure, add_zero]
+  | query_bind input next ih =>
+      rw [monitoredWorldRun_query_bind, tsum_probOutput_bind_mul, expectedWorldPayment_query_bind]
+      calc
+        _ = ∑' result, Pr[= result | monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+              required stopAfter input state] *
+            (counter result.2.2 +
+              expectedWorldPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+                charge (next result.1.1.1) result.2) := by
+          apply tsum_congr
+          intro result
+          by_cases hr : Pr[= result | monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+              required stopAfter input state] = 0
+          · simp only [hr, zero_mul]
+          · rw [SPMF.probOutput_eq_apply] at hr
+            rw [tsum_probOutput_map_mul]
+            apply congrArg (_ * ·)
+            exact ih result.1.1.1 result.2
+              (monitoredStep_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+                (.inl input) state hvalid result hr)
+        _ = _ := by
+          simp only [mul_add, ENNReal.tsum_add]
+          rw [hstep input state hvalid, add_assoc]
+
+theorem expected_monitoredWorldRun_creationCost {Result : Type} (computation : OracleComp OracleWorld Result) (state : MonitoredState)
+    (hvalid : Valid state) :
+    (∑' result, Pr[= result | monitoredWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter computation state] * result.2.2.creationCost) =
+      state.2.creationCost +
+        expectedWorldCharge parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          computation state :=
+  expected_monitoredWorldRun_accumulator parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+    CertificateMonitor.creationCost (certificateMonitorCharge (monitorKey parameter root) budget required)
+    (fun input state hvalid => by
+      rw [← monitoredStep_inl]
+      exact expected_monitoredStep_creationCost parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter (.inl input) state hvalid) computation state hvalid
+
+/-! ### The completed run -/
+
+noncomputable def verifyComputation (forgery : Forgery) : OracleComp OracleWorld Bool :=
+  liftM (verify ⟨root, parameter⟩ forgery.message forgery.signature : OracleComp HashSpec Bool)
+
+noncomputable def expectedCompletedCharge (adversary : Adversary) (state : MonitoredState) : ENNReal :=
+  expectedMonitoredCharge parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      (adversary.main ⟨root, parameter⟩) state +
+    ∑' before, Pr[= before | monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+      stopAfter (adversary.main ⟨root, parameter⟩) state] *
+      expectedWorldCharge parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        (verifyComputation parameter root before.1.1.1.1) before.2
+
+theorem monitoredCompletedRun_eq (adversary : Adversary) (state : MonitoredState) :
+    monitoredCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter adversary state =
+      (monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        (adversary.main ⟨root, parameter⟩) state >>= fun before =>
+        (fun checked => ((before.1, checked.1), checked.2)) <$>
+          monitoredWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+            (verifyComputation parameter root before.1.1.1.1) before.2) := rfl
+
+include hauxiliary in
+theorem expected_monitoredCompletedRun_potential_le (adversary : Adversary) (state : MonitoredState) (hvalid : Valid state)
+    (hcovered : CoveredRun parameter root otsSecret inputs (adversary.main ⟨root, parameter⟩) state) :
+    (∑' result, Pr[= result | monitoredCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter adversary state] *
+      certificateMonitorPotential (monitorKey parameter root) budget required (monitorView result.2)) ≤
+      certificateMonitorPotential (monitorKey parameter root) budget required (monitorView state) +
+        expectedCompletedCharge parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          adversary state := by
+  rw [monitoredCompletedRun_eq, tsum_probOutput_bind_mul, expectedCompletedCharge, ← add_assoc]
+  calc
+    _ ≤ ∑' before, Pr[= before | monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter (adversary.main ⟨root, parameter⟩) state] *
+        (certificateMonitorPotential (monitorKey parameter root) budget required (monitorView before.2) +
+          expectedWorldCharge parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+            (verifyComputation parameter root before.1.1.1.1) before.2) := by
+      apply ENNReal.tsum_le_tsum
+      intro before
+      by_cases hb : Pr[= before | monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter (adversary.main ⟨root, parameter⟩) state] = 0
+      · simp only [hb, zero_mul, le_refl]
+      · rw [SPMF.probOutput_eq_apply] at hb
+        rw [tsum_probOutput_map_mul]
+        apply mul_le_mul' le_rfl
+        have hfinal := monitoredRun_covered parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          hauxiliary (adversary.main ⟨root, parameter⟩) state hvalid hcovered before hb
+        have hvalid' := monitoredRun_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          (adversary.main ⟨root, parameter⟩) state hvalid before hb
+        exact expected_monitoredWorldRun_potential_le parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+          required stopAfter (verifyComputation parameter root before.1.1.1.1) before.2
+          (covered_pure parameter root otsSecret inputs before.1.1.1.1 before.2 hvalid' hfinal)
+    _ = _ := by
+      simp only [mul_add, ENNReal.tsum_add]
+    _ ≤ _ :=
+      add_le_add (expected_monitoredRun_potential_le parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter hauxiliary (adversary.main ⟨root, parameter⟩) state hvalid hcovered) le_rfl
+
+theorem expected_monitoredCompletedRun_creationCost (adversary : Adversary) (state : MonitoredState) (hvalid : Valid state) :
+    (∑' result, Pr[= result | monitoredCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter adversary state] * result.2.2.creationCost) =
+      state.2.creationCost +
+        expectedCompletedCharge parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          adversary state := by
+  rw [monitoredCompletedRun_eq, tsum_probOutput_bind_mul, expectedCompletedCharge, ← add_assoc]
+  calc
+    _ = ∑' before, Pr[= before | monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter (adversary.main ⟨root, parameter⟩) state] *
+        (before.2.2.creationCost +
+          expectedWorldCharge parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+            (verifyComputation parameter root before.1.1.1.1) before.2) := by
+      apply tsum_congr
+      intro before
+      by_cases hb : Pr[= before | monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter (adversary.main ⟨root, parameter⟩) state] = 0
+      · simp only [hb, zero_mul]
+      · rw [SPMF.probOutput_eq_apply] at hb
+        rw [tsum_probOutput_map_mul]
+        apply congrArg (_ * ·)
+        exact expected_monitoredWorldRun_creationCost parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+          required stopAfter (verifyComputation parameter root before.1.1.1.1) before.2
+          (monitoredRun_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+            (adversary.main ⟨root, parameter⟩) state hvalid before hb)
+    _ = _ := by
+      simp only [mul_add, ENNReal.tsum_add]
+      rw [expected_monitoredRun_creationCost parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter (adversary.main ⟨root, parameter⟩) state hvalid]
+
+include hauxiliary in
+theorem expected_monitoredCompletedRun_count_le_creationCost (adversary : Adversary) (spent : Nat) (stopped : Bool)
+    (hcovered : CoveredRun parameter root otsSecret inputs (adversary.main ⟨root, parameter⟩)
+      ((∅, SecretGuessObservation.initialState PUnit.unit), initialCertificateMonitor spent stopped)) :
+    (∑' result, Pr[= result | monitoredCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter adversary ((∅, SecretGuessObservation.initialState PUnit.unit), initialCertificateMonitor spent stopped)] *
+      certificateBankCount result.2.2.bank) ≤
+      ∑' result, Pr[= result | monitoredCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter adversary ((∅, SecretGuessObservation.initialState PUnit.unit), initialCertificateMonitor spent stopped)] *
+        result.2.2.creationCost := by
+  have hvalid : Valid ((∅, SecretGuessObservation.initialState PUnit.unit), initialCertificateMonitor spent stopped) :=
+    fun _ => Finset.univ_nonempty
+  have hpotential := expected_monitoredCompletedRun_potential_le parameter root otsSecret labels inputs hencoding selections rows dummy slot
+    budget required stopAfter hauxiliary adversary _ hvalid hcovered
+  rw [expected_monitoredCompletedRun_creationCost parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+    stopAfter adversary _ hvalid]
+  have hzero : certificateMonitorPotential (monitorKey parameter root) budget required
+      (monitorView ((∅, SecretGuessObservation.initialState PUnit.unit), initialCertificateMonitor spent stopped)) = 0 :=
+    certificateMonitorPotential_initial (monitorKey parameter root) budget spent required ∅ stopped (fun _ _ => rfl)
+  rw [hzero, zero_add] at hpotential
+  simp only [initialCertificateMonitor, zero_add]
+  refine le_trans ?_ hpotential
+  exact ENNReal.tsum_le_tsum fun result => mul_le_mul' le_rfl (certificateBankCount_le_bankedCacheWeight _ _ _ _ _)
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessMonitoredPotential.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessMonitoredPotential.lean
new file mode 100644
index 000000000..c1917e867
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessMonitoredPotential.lean
@@ -0,0 +1,403 @@
+import SphincsSecurity.Proof.Forced.FtsGuessMonitoredValid
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec UniformTableCompletion OtsContactTrace ENNReal
+open FtsGuessSigning (Coordinate)
+open FtsProbeSimulation (MessageHashInput messageAnswers)
+open SecretGuessObservation (State environment)
+open RetainedResidual (proposalOfSigningRecord proposalOfWorldResult signingAnnotation worldMonitorValue completedSigningBankValue)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  publicDigestLoop canonicalGraphRoot canonicalGraphInput hashInputs UniformTableCompletion.complete
+
+variable (parameter : PublicParameter) (root : Digest)
+  (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+  (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+  (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (dummy : OtsReferenceWords) (slot : Nat)
+  (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+theorem monitorView_fst (state : MonitoredState) : (monitorView state).1 = state.1.1 := rfl
+
+/-! ### World steps -/
+
+theorem monitorView_snd (state : MonitoredState) : (monitorView state).2 = state.2 := rfl
+
+theorem expected_monitoredWorldStep_potential_le (input : OracleWorld.Domain) (state : MonitoredState)
+    (hinputs : hashInputs (liftM (OracleWorld.query input)) ⊆ inputs) :
+    (∑' result, Pr[= result | monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter input state] *
+      certificateMonitorPotential (monitorKey parameter root) budget required (monitorView result.2)) ≤
+      certificateMonitorPotential (monitorKey parameter root) budget required (monitorView state) +
+        certificateMonitorCharge (monitorKey parameter root) budget required (.inl input) (monitorView state) := by
+  have hweight : (∑' result, Pr[= result | monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot
+      budget required stopAfter input state] * certificateMonitorPotential (monitorKey parameter root) budget required (monitorView result.2)) =
+      ∑' result, Pr[= result | cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+        (worldProgram parameter labels input) state.1] *
+        worldMonitorValue (monitorKey parameter root) budget required stopAfter input (monitorView state) 0 (some result.1, result.2.1) := by
+    rw [monitoredWorldStep, tsum_probOutput_map_mul]
+    rfl
+  rw [hweight]
+  have hpointwise (hcache : ∀ result, cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+      (worldProgram parameter labels input) state.1 result ≠ 0 → messageAnswers parameter result.2.1 = messageAnswers parameter state.1.1) :
+      (∑' result, Pr[= result | cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+        (worldProgram parameter labels input) state.1] *
+        worldMonitorValue (monitorKey parameter root) budget required stopAfter input (monitorView state) 0 (some result.1, result.2.1)) ≤
+        certificateMonitorPotential (monitorKey parameter root) budget required (monitorView state) := by
+    calc
+      _ ≤ ∑' result, Pr[= result | cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+          (worldProgram parameter labels input) state.1] *
+          certificateMonitorPotential (monitorKey parameter root) budget required (monitorView state) := by
+        apply ENNReal.tsum_le_tsum
+        intro result
+        by_cases hr : Pr[= result | cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+            (worldProgram parameter labels input) state.1] = 0
+        · simp only [hr, zero_mul, le_refl]
+        · apply mul_le_mul' le_rfl
+          rw [SPMF.probOutput_eq_apply] at hr
+          exact RetainedResidual.worldMonitorValue_le_of_messageHistory (monitorKey parameter root) budget required stopAfter input
+            (monitorView state) 0 (some result.1, result.2.1) (hcache result hr)
+      _ ≤ _ := by
+        rw [ENNReal.tsum_mul_right]
+        exact mul_le_of_le_one_left' tsum_probOutput_le_one
+  cases input with
+  | inl sample =>
+      refine (hpointwise fun result hr => ?_).trans le_self_add
+      rw [cachedForcedRun_world_unif'] at hr
+      obtain ⟨answer, _, heq⟩ := map_nonzero_source' _ _ _ hr
+      rw [heq]
+  | inr hash =>
+      have hin : hash ∈ inputs := hinputs (by simpa only [bind_pure] using mem_hashInputs_hash_bind hash pure)
+      by_cases hmessage : MessageHashInput parameter hash
+      · rw [cachedForcedRun_world_message' parameter root otsSecret labels inputs hencoding selections rows dummy slot hash hin hmessage state.1,
+          tsum_probOutput_map_mul]
+        by_cases hactive : CertificateMonitorActive (monitorKey parameter root) budget (.inl (.inr hash)) (monitorView state)
+        · have hbound := expected_originalProposalRecord_world_banked_le (monitorKey parameter root) nearUniformDigestReuseWeight
+            (budget - state.2.spent) (signatureLimit - state.2.log.length) required (certificateMonitorCoverState (monitorView state))
+            state.2.bank (.inr hash) (fun _ => false) hactive.2.1.1 hactive.2.2.2
+          calc
+            _ ≤ ∑' result, Pr[= result | 𝒟[(romImpl (.inr hash)).run state.1.1]] *
+                bankedProposalRecordValue (monitorKey parameter root) nearUniformDigestReuseWeight (budget - state.2.spent)
+                  (signatureLimit - state.2.log.length) required (certificateMonitorCoverState (monitorView state)) state.2.bank
+                  (.inl (.inr hash)) (proposalOfWorldResult (monitorKey parameter root).parameter (.inr hash) (result.1, result.2)) false := by
+              apply ENNReal.tsum_le_tsum
+              intro result
+              apply mul_le_mul' le_rfl
+              simp only [worldMonitorValue, Option.elim_some,
+                certificateMonitorPotential_advance_active (monitorKey parameter root) budget required stopAfter (.inl (.inr hash))
+                  (monitorView state) _ _ hactive, signingLogFragment, List.append_nil]
+              exact bankedCacheWeight_discard_le _ _ _ _ _
+            _ = ∑' record, Pr[= record | originalProposalRecord (monitorKey parameter root) (.inl (.inr hash)) (monitorView state).1] *
+                bankedProposalRecordValue (monitorKey parameter root) nearUniformDigestReuseWeight (budget - state.2.spent)
+                  (signatureLimit - state.2.log.length) required (certificateMonitorCoverState (monitorView state)) state.2.bank
+                  (.inl (.inr hash)) record false := by
+              rw [originalProposalRecord, ← PMF.monad_map_eq_map, tsum_probOutput_map_mul]
+              rfl
+            _ ≤ _ := by
+              have hlive : state.2.stopped = false := hactive.1
+              simpa only [certificateMonitorPotential, certificateMonitorCoverState, monitorView_fst, monitorView_snd, hlive,
+                certificateMonitorCharge, if_pos hactive] using hbound
+        · simp only [worldMonitorValue, Option.elim_some, certificateMonitorCharge, if_neg hactive, add_zero,
+            certificateMonitorPotential_advance_inactive (monitorKey parameter root) budget required stopAfter (.inl (.inr hash))
+              (monitorView state) _ _ hactive, ENNReal.tsum_mul_right]
+          exact (mul_le_of_le_one_left' tsum_probOutput_le_one).trans (certificateBankCount_le_bankedCacheWeight _ _ _ _ _)
+      · refine (hpointwise fun result hr => ?_).trans le_self_add
+        have hsupport := cachedForcedRun_world_hash_support' parameter root otsSecret labels inputs hencoding selections rows dummy slot
+          hash state.1 result hr
+        exact messageAnswers_eq_of_cache_of_ne parameter state.1.1 result.2.1 hash hmessage hsupport.1
+
+/-! ### Signing steps -/
+
+def secretLabels (secrets : Coordinate → Digest) : CanonicalProbeRouting.Labels
+  | .ftsStart index tree leaf => secrets (index, tree, leaf)
+  | .otsStart _ _ _ _ => 0
+  | .graph _ => 0
+
+theorem publicSigningWork_bank_digest (key : SecretKey) (known : CanonicalProbeRouting.Labels) (words : OtsReferenceWords)
+    (selections : ReferenceFamily) (actual : CanonicalProbeRouting.Labels) (message : Message) (cache : QueryCache HashSpec) :
+    (fun result => ((completePublicSigningRecord (fun index tree leaf => actual (.ftsStart index tree leaf)) result.1).1, result.2)) <$>
+      𝒟[(simulateQ romImpl (Prod.fst <$> ResidualByteFrontend.publicSigningWork key.parameter key.root known words selections message)).run cache] =
+        RetainedResidual.digestCompletionValue known words selections actual <$>
+          𝒟[(simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run cache] := by
+  rw [simulateQ_map, StateT.run_map, evalDist_map, Functor.map_map]
+  exact publicSigningWork_complete_digest key known words selections actual message cache
+
+theorem expected_publicSigningWork_bank_le (key : SecretKey) (known : CanonicalProbeRouting.Labels) (words : OtsReferenceWords)
+    (selections : ReferenceFamily) (actual : CanonicalProbeRouting.Labels) (message : Message) (reuse : ENNReal)
+    (budget signatures : Nat) (required : Finset FtsTree) (cache : QueryCache HashSpec) (log : QueryLog SigningSpec)
+    (bank : HashInput → Bool) (hsigned : SigningDigestsCached key.parameter cache key.root log)
+    (hreuse : exactDigestReuseWeight key message cache ≤ reuse) :
+    (∑' result, Pr[= result | 𝒟[(simulateQ romImpl (Prod.fst <$> ResidualByteFrontend.publicSigningWork key.parameter key.root known words
+        selections message)).run cache]] *
+      completedSigningBankValue key reuse budget signatures required log bank message
+        ((completePublicSigningRecord (fun index tree leaf => actual (.ftsStart index tree leaf)) result.1).1, result.2)) ≤
+      bankedTargetEnvelope key reuse budget (signatures + 1) required (cache, log) bank false +
+        targetCreationMultiplier key cache (.inr message) * targetCreationPrice key reuse budget (signatures + 1) required (cache, log) := by
+  have h := congrArg (fun law => ∑' result, Pr[= result | law] *
+    completedSigningBankValue key reuse budget signatures required log bank message result)
+    (publicSigningWork_bank_digest key known words selections actual message cache)
+  rw [tsum_probOutput_map_mul] at h
+  rw [h]
+  have hb := RetainedResidual.expected_digestCompletionValue_bank_le key reuse budget signatures required (cache, log) bank message
+    known words selections actual hsigned hreuse
+  simpa only [evalDist_map, probOutput_def, SPMF.evalDist_def] using hb
+
+theorem expected_forcedSigning_bank_le (message : Message) (state : MonitoredState) (hvalid : Valid state)
+    (hinputs : hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs)
+    (reuse : ENNReal) (signatures : Nat) (bank : HashInput → Bool)
+    (hsigned : SigningDigestsCached parameter state.1.1 root state.2.log)
+    (hreuse : exactDigestReuseWeight (monitorKey parameter root) message state.1.1 ≤ reuse) :
+    (∑' result, Pr[= result | cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+        (signingProgram message) state.1] *
+      completedSigningBankValue (monitorKey parameter root) reuse (budget - state.2.spent) signatures required state.2.log bank message
+        (result.1.1, result.2.1)) ≤
+      bankedTargetEnvelope (monitorKey parameter root) reuse (budget - state.2.spent) (signatures + 1) required (state.1.1, state.2.log) bank false +
+        targetCreationMultiplier (monitorKey parameter root) state.1.1 (.inr message) *
+          targetCreationPrice (monitorKey parameter root) reuse (budget - state.2.spent) (signatures + 1) required (state.1.1, state.2.log) := by
+  rw [cachedForcedRun_signingProgram' parameter root otsSecret labels inputs hencoding selections rows dummy slot message state.1 hvalid hinputs
+    (referenceAnswers parameter root otsSecret labels inputs hencoding ⟨selections, rows, fun _ => 0⟩ dummy), tsum_probOutput_bind_mul]
+  simp only [tsum_probOutput_map_mul]
+  calc
+    _ ≤ ∑' secrets, Pr[= secrets | complete state.1.2.allowed] *
+        (bankedTargetEnvelope (monitorKey parameter root) reuse (budget - state.2.spent) (signatures + 1) required (state.1.1, state.2.log) bank false +
+          targetCreationMultiplier (monitorKey parameter root) state.1.1 (.inr message) *
+            targetCreationPrice (monitorKey parameter root) reuse (budget - state.2.spent) (signatures + 1) required (state.1.1, state.2.log)) := by
+      apply ENNReal.tsum_le_tsum
+      intro secrets
+      apply mul_le_mul' le_rfl
+      exact expected_publicSigningWork_bank_le (monitorKey parameter root) (known otsSecret labels) (referenceFamilyWords selections dummy)
+        selections (secretLabels secrets) message reuse (budget - state.2.spent) signatures required state.1.1 state.2.log bank hsigned hreuse
+    _ ≤ _ := by
+      rw [ENNReal.tsum_mul_right]
+      exact mul_le_of_le_one_left' tsum_probOutput_le_one
+
+theorem expected_forcedSigning_certificateMonitor_le (message : Message) (state : MonitoredState) (hvalid : Valid state)
+    (hinputs : hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs) (annotation : Nat × Index) :
+    (∑' result, Pr[= result | cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+        (signingProgram message) state.1] *
+      certificateMonitorPotential (monitorKey parameter root) budget required
+        (originalProposalAdvance (certificateMonitorUpdate (monitorKey parameter root) budget required stopAfter) (.inr message)
+          (monitorView state) annotation.1
+          (proposalOfSigningRecord message result.1 result.2.1 (result.1.1.2.elim annotation.2 Prod.fst)))) ≤
+      certificateMonitorPotential (monitorKey parameter root) budget required (monitorView state) +
+        certificateMonitorCharge (monitorKey parameter root) budget required (.inr message) (monitorView state) := by
+  by_cases hactive : CertificateMonitorActive (monitorKey parameter root) budget (.inr message) (monitorView state)
+  · have hdata := hactive
+    obtain ⟨hlive, ⟨hsigned, hcapacity, _⟩, hvalidStep, _⟩ := hdata
+    have hremaining : signatureLimit - (state.2.log.length + 1) + 1 = signatureLimit - state.2.log.length := by
+      change state.2.log.length < signatureLimit at hvalidStep
+      omega
+    have hreuse := exactDigestReuseWeight_le_near_uniform_of_clean_cache (monitorKey parameter root) state.1.1 state.2.spent
+      hcapacity.spent_le hcapacity.cache_le hcapacity.no_deficit message
+    calc
+      _ ≤ ∑' result, Pr[= result | cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+          (signingProgram message) state.1] *
+          completedSigningBankValue (monitorKey parameter root) nearUniformDigestReuseWeight (budget - state.2.spent)
+            (signatureLimit - (state.2.log.length + 1)) required state.2.log state.2.bank message (result.1.1, result.2.1) := by
+        apply ENNReal.tsum_le_tsum
+        intro result
+        apply mul_le_mul' le_rfl
+        simp only [certificateMonitorPotential_advance_active (monitorKey parameter root) budget required stopAfter (.inr message)
+          (monitorView state) _ _ hactive, signingLogFragment, List.length_append, List.length_singleton]
+        exact RetainedResidual.bankedProposalRecordValue_le_completedSigningBank (monitorKey parameter root) nearUniformDigestReuseWeight
+          (budget - state.2.spent) (signatureLimit - (state.2.log.length + 1)) required (certificateMonitorCoverState (monitorView state))
+          state.2.bank message (proposalOfSigningRecord message result.1 result.2.1 (result.1.1.2.elim annotation.2 Prod.fst)) _
+      _ ≤ _ := by
+        have h := expected_forcedSigning_bank_le parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          message state hvalid hinputs nearUniformDigestReuseWeight (signatureLimit - (state.2.log.length + 1)) state.2.bank hsigned hreuse
+        rw [hremaining] at h
+        have hlive' : state.2.stopped = false := hlive
+        simpa only [certificateMonitorPotential, certificateMonitorCoverState, monitorView_fst, monitorView_snd, hlive',
+          certificateMonitorCharge, if_pos hactive] using h
+  · rw [certificateMonitorCharge, if_neg hactive, add_zero]
+    simp only [certificateMonitorPotential_advance_inactive (monitorKey parameter root) budget required stopAfter (.inr message)
+      (monitorView state) _ _ hactive, ENNReal.tsum_mul_right]
+    exact (mul_le_of_le_one_left' tsum_probOutput_le_one).trans (certificateBankCount_le_bankedCacheWeight _ _ _ _ _)
+
+theorem expected_monitoredSignStep_potential_le (message : Message) (state : MonitoredState) (hvalid : Valid state)
+    (hinputs : hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs) :
+    (∑' result, Pr[= result | monitoredSignStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter message state] *
+      certificateMonitorPotential (monitorKey parameter root) budget required (monitorView result.2)) ≤
+      certificateMonitorPotential (monitorKey parameter root) budget required (monitorView state) +
+        certificateMonitorCharge (monitorKey parameter root) budget required (.inr message) (monitorView state) := by
+  rw [monitoredSignStep, tsum_probOutput_bind_mul]
+  simp only [tsum_probOutput_map_mul]
+  calc
+    _ ≤ ∑' annotation, Pr[= annotation | (liftM (signingAnnotation (monitorKey parameter root) budget message (monitorView state)) : SPMF _)] *
+        (certificateMonitorPotential (monitorKey parameter root) budget required (monitorView state) +
+          certificateMonitorCharge (monitorKey parameter root) budget required (.inr message) (monitorView state)) := by
+      apply ENNReal.tsum_le_tsum
+      intro annotation
+      apply mul_le_mul' le_rfl
+      exact expected_forcedSigning_certificateMonitor_le parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+        required stopAfter message state hvalid hinputs annotation
+    _ ≤ _ := by
+      rw [ENNReal.tsum_mul_right]
+      exact mul_le_of_le_one_left' tsum_probOutput_le_one
+
+/-! ### One adversary step -/
+
+theorem expected_monitoredStep_potential_le (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Forgery)
+    (state : MonitoredState) (hvalid : Valid state)
+    (hcovered : CoveredRun parameter root otsSecret inputs (liftM ((OracleWorld + SigningSpec).query input) >>= next) state) :
+    (∑' result, Pr[= result | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter input state] *
+      certificateMonitorPotential (monitorKey parameter root) budget required (monitorView result.2)) ≤
+      certificateMonitorPotential (monitorKey parameter root) budget required (monitorView state) +
+        certificateMonitorCharge (monitorKey parameter root) budget required input (monitorView state) := by
+  cases input with
+  | inl input =>
+      exact expected_monitoredWorldStep_potential_le parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+        required stopAfter input state (covered_world_inputs parameter root otsSecret inputs input next state hvalid hcovered)
+  | inr message =>
+      exact expected_monitoredSignStep_potential_le parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+        required stopAfter message state hvalid (covered_sign_digest parameter root otsSecret inputs message next state hvalid hcovered)
+
+/-! ### Telescoping over the adversary run -/
+
+variable (hauxiliary : ∀ seed : inputs → HashOutput,
+  (⟨selections, rows, seed⟩ : ReferenceAuxiliary inputs) ∈ (referenceAuxiliarySample inputs).support)
+
+noncomputable def expectedMonitoredCharge (computation : OracleComp (OracleWorld + SigningSpec) Forgery) :
+    MonitoredState → ENNReal :=
+  OracleComp.construct (fun _ _ => 0) (fun input _ next state =>
+    certificateMonitorCharge (monitorKey parameter root) budget required input (monitorView state) +
+      ∑' result, Pr[= result | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter input state] * next result.1.1.1 result.2) computation
+
+theorem expectedMonitoredCharge_pure (forgery : Forgery) (state : MonitoredState) :
+    expectedMonitoredCharge parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      (pure forgery) state = 0 := rfl
+
+theorem expectedMonitoredCharge_query_bind (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Forgery) (state : MonitoredState) :
+    expectedMonitoredCharge parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      (liftM ((OracleWorld + SigningSpec).query input) >>= next) state =
+      certificateMonitorCharge (monitorKey parameter root) budget required input (monitorView state) +
+        ∑' result, Pr[= result | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter input state] *
+          expectedMonitoredCharge parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+            (next result.1.1.1) result.2 := rfl
+
+include hauxiliary in
+theorem covered_step_next (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Forgery)
+    (state : MonitoredState) (hvalid : Valid state)
+    (hcovered : CoveredRun parameter root otsSecret inputs (liftM ((OracleWorld + SigningSpec).query input) >>= next) state)
+    (result : AdversaryStep input × MonitoredState)
+    (hresult : monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      input state result ≠ 0) :
+    CoveredRun parameter root otsSecret inputs (next result.1.1.1) result.2 := by
+  cases input with
+  | inl input =>
+      exact covered_world_next parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input
+        next state hcovered result hresult
+  | inr message =>
+      exact covered_sign_next parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter message
+        next state hvalid hauxiliary hcovered result hresult
+
+include hauxiliary in
+theorem expected_monitoredRun_potential_le (computation : OracleComp (OracleWorld + SigningSpec) Forgery)
+    (state : MonitoredState) (hvalid : Valid state) (hcovered : CoveredRun parameter root otsSecret inputs computation state) :
+    (∑' result, Pr[= result | monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter computation state] *
+      certificateMonitorPotential (monitorKey parameter root) budget required (monitorView result.2)) ≤
+      certificateMonitorPotential (monitorKey parameter root) budget required (monitorView state) +
+        expectedMonitoredCharge parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          computation state := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value =>
+      simp only [monitoredRun_pure, tsum_probOutput_pure_mul, expectedMonitoredCharge_pure, add_zero, le_refl]
+  | query_bind input next ih =>
+      rw [monitoredRun_query_bind, tsum_probOutput_bind_mul, expectedMonitoredCharge_query_bind]
+      calc
+        _ ≤ ∑' result, Pr[= result | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+              stopAfter input state] *
+            (certificateMonitorPotential (monitorKey parameter root) budget required (monitorView result.2) +
+              expectedMonitoredCharge parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+                (next result.1.1.1) result.2) := by
+          apply ENNReal.tsum_le_tsum
+          intro result
+          by_cases hr : Pr[= result | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+              stopAfter input state] = 0
+          · simp only [hr, zero_mul, le_refl]
+          · rw [SPMF.probOutput_eq_apply] at hr
+            rw [tsum_probOutput_map_mul]
+            apply mul_le_mul' le_rfl
+            exact ih result.1.1.1 result.2
+              (monitoredStep_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+                input state hvalid result hr)
+              (covered_step_next parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+                hauxiliary input next state hvalid hcovered result hr)
+        _ = (∑' result, Pr[= result | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+              stopAfter input state] * certificateMonitorPotential (monitorKey parameter root) budget required (monitorView result.2)) +
+            ∑' result, Pr[= result | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+              stopAfter input state] *
+              expectedMonitoredCharge parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+                (next result.1.1.1) result.2 := by
+          simp only [mul_add, ENNReal.tsum_add]
+        _ ≤ _ := by
+          rw [← add_assoc]
+          exact add_le_add (expected_monitoredStep_potential_le parameter root otsSecret labels inputs hencoding selections rows dummy slot
+            budget required stopAfter input next state hvalid hcovered) le_rfl
+
+/-! ### Telescoping over the verifier -/
+
+noncomputable def expectedWorldCharge {Result : Type} (computation : OracleComp OracleWorld Result) : MonitoredState → ENNReal :=
+  OracleComp.construct (fun _ _ => 0) (fun input _ next state =>
+    certificateMonitorCharge (monitorKey parameter root) budget required (.inl input) (monitorView state) +
+      ∑' result, Pr[= result | monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter input state] * next result.1.1.1 result.2) computation
+
+theorem expectedWorldCharge_pure {Result : Type} (value : Result) (state : MonitoredState) :
+    expectedWorldCharge parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      (pure value) state = 0 := rfl
+
+theorem expectedWorldCharge_query_bind {Result : Type} (input : OracleWorld.Domain)
+    (next : OracleWorld.Range input → OracleComp OracleWorld Result) (state : MonitoredState) :
+    expectedWorldCharge parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      (liftM (OracleWorld.query input) >>= next) state =
+      certificateMonitorCharge (monitorKey parameter root) budget required (.inl input) (monitorView state) +
+        ∑' result, Pr[= result | monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter input state] *
+          expectedWorldCharge parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+            (next result.1.1.1) result.2 := rfl
+
+theorem expected_monitoredWorldRun_potential_le {Result : Type} (computation : OracleComp OracleWorld Result)
+    (state : MonitoredState) (hinputs : hashInputs computation ⊆ inputs) :
+    (∑' result, Pr[= result | monitoredWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter computation state] *
+      certificateMonitorPotential (monitorKey parameter root) budget required (monitorView result.2)) ≤
+      certificateMonitorPotential (monitorKey parameter root) budget required (monitorView state) +
+        expectedWorldCharge parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          computation state := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value =>
+      simp only [monitoredWorldRun_pure, tsum_probOutput_pure_mul, expectedWorldCharge_pure, add_zero, le_refl]
+  | query_bind input next ih =>
+      rw [monitoredWorldRun_query_bind, tsum_probOutput_bind_mul, expectedWorldCharge_query_bind]
+      calc
+        _ ≤ ∑' result, Pr[= result | monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+              required stopAfter input state] *
+            (certificateMonitorPotential (monitorKey parameter root) budget required (monitorView result.2) +
+              expectedWorldCharge parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+                (next result.1.1.1) result.2) := by
+          apply ENNReal.tsum_le_tsum
+          intro result
+          rw [tsum_probOutput_map_mul]
+          exact mul_le_mul' le_rfl (ih result.1.1.1 result.2 ((hashInputs_world_next input next result.1.1.1).trans hinputs))
+        _ = (∑' result, Pr[= result | monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+              required stopAfter input state] * certificateMonitorPotential (monitorKey parameter root) budget required (monitorView result.2)) +
+            ∑' result, Pr[= result | monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+              required stopAfter input state] *
+              expectedWorldCharge parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+                (next result.1.1.1) result.2 := by
+          simp only [mul_add, ENNReal.tsum_add]
+        _ ≤ _ := by
+          rw [← add_assoc]
+          exact add_le_add (expected_monitoredWorldStep_potential_le parameter root otsSecret labels inputs hencoding selections rows dummy
+            slot budget required stopAfter input state ((hashInputs_world_query input next).trans hinputs)) le_rfl
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessMonitoredStep.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessMonitoredStep.lean
new file mode 100644
index 000000000..863c984fe
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessMonitoredStep.lean
@@ -0,0 +1,270 @@
+import SphincsSecurity.Proof.Forced.FtsGuessInputCoverage
+import SphincsSecurity.Proof.Residual.RetainedResidualMonitoredStep
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec UniformTableCompletion OtsContactTrace
+open FtsGuessSigning (Coordinate)
+open SecretGuessObservation (State)
+open RetainedResidual (proposalOfSigningRecord proposalOfWorldResult signingAnnotation)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  publicDigestLoop canonicalGraphRoot canonicalGraphInput hashInputs
+
+variable (parameter : PublicParameter) (root : Digest)
+  (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+  (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+  (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (dummy : OtsReferenceWords) (slot : Nat)
+
+theorem cachedForcedRun_map {First Result : Type} (function : First → Result) (computation : OracleComp World First)
+    (state : CachedState) :
+    cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot (function <$> computation) state =
+      (fun result => (function result.1, result.2)) <$>
+        cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot computation state := by
+  simp only [cachedForcedRun, simulateQ_map, StateT.run_map]
+
+/-! ### The adversary run, one query at a time -/
+
+abbrev AdversaryStep (input : (OracleWorld + SigningSpec).Domain) :=
+  ((OracleWorld + SigningSpec).Range input × SigningBoundaryTrace) × Trace
+
+def combineStep {Result : Type} (input : (OracleWorld + SigningSpec).Domain) (step : AdversaryStep input)
+    (tail : ((Result × QueryLog SigningSpec) × SigningBoundaryTrace) × Trace) :
+    ((Result × QueryLog SigningSpec) × SigningBoundaryTrace) × Trace :=
+  (((tail.1.1.1, signingLogFragment input step.1.1 ++ tail.1.1.2), step.1.2 * tail.1.2), step.2 * tail.2)
+
+theorem adversaryRun_pure {Result : Type} (value : Result) :
+    adversaryRun parameter labels (pure value) = pure (((value, []), 1), 1) := by
+  simp only [adversaryRun, logged_eq_signingTrace, FtsProbeSimulation.signingTraceComputation, OracleComp.construct_pure,
+    simulateQ_pure, WriterT.run_pure]
+
+theorem adversaryRun_query_bind {Result : Type} (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Result) :
+    adversaryRun parameter labels (liftM ((OracleWorld + SigningSpec).query input) >>= next) =
+      ((adversaryImpl parameter labels input).run.run >>= fun step =>
+        combineStep input step <$> adversaryRun parameter labels (next step.1.1)) := by
+  simp only [adversaryRun, logged_eq_signingTrace, FtsProbeSimulation.signingTraceComputation_query_bind, simulateQ_bind,
+    simulateQ_spec_query, simulateQ_map, WriterT.run_bind, WriterT.run_map, Functor.map_map]
+  rfl
+
+noncomputable def forcedAdversaryStep (input : (OracleWorld + SigningSpec).Domain) (state : CachedState) :
+    SPMF (AdversaryStep input × CachedState) :=
+  cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+    ((adversaryImpl parameter labels input).run.run) state
+
+theorem cachedForcedRun_adversaryRun_pure {Result : Type} (value : Result) (state : CachedState) :
+    cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+      (adversaryRun parameter labels (pure value)) state = pure ((((value, []), 1), 1), state) := by
+  rw [adversaryRun_pure, cachedForcedRun_pure]
+
+theorem cachedForcedRun_adversaryRun_query_bind {Result : Type} (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Result) (state : CachedState) :
+    cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+      (adversaryRun parameter labels (liftM ((OracleWorld + SigningSpec).query input) >>= next)) state =
+      (forcedAdversaryStep parameter root otsSecret labels inputs hencoding selections rows dummy slot input state >>= fun step =>
+        (fun tail => (combineStep input step.1 tail.1, tail.2)) <$>
+          cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+            (adversaryRun parameter labels (next step.1.1.1)) step.2) := by
+  rw [adversaryRun_query_bind, cachedForcedRun_bind]
+  apply congrArg (_ >>= ·)
+  funext step
+  rw [cachedForcedRun_map]
+
+theorem forcedAdversaryStep_world (input : OracleWorld.Domain) (state : CachedState) :
+    forcedAdversaryStep parameter root otsSecret labels inputs hencoding selections rows dummy slot (.inl input) state =
+      (fun result => (((result.1, signingBoundaryTrace parameter input result.1), hashObservationTrace input result.1), result.2)) <$>
+        cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot (worldProgram parameter labels input) state := by
+  rw [forcedAdversaryStep]
+  simp only [adversaryImpl, WriterT.run_mk]
+  rw [cachedForcedRun_map]
+  rfl
+
+theorem forcedAdversaryStep_sign (message : Message) (state : CachedState) :
+    forcedAdversaryStep parameter root otsSecret labels inputs hencoding selections rows dummy slot (.inr message) state =
+      (fun result => (((result.1.1.1, result.1.2), 1), result.2)) <$>
+        cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot (signingProgram message) state := by
+  rw [forcedAdversaryStep]
+  simp only [adversaryImpl, WriterT.run_mk]
+  rw [cachedForcedRun_map]
+
+/-! ### The passive certificate monitor -/
+
+abbrev MonitoredState := CachedState × CertificateMonitor
+
+def monitorView (state : MonitoredState) : CertificateMonitorState := (state.1.1, state.2)
+
+def monitorKey : SecretKey := ⟨parameter, root, fun _ _ _ _ => 0, fun _ _ _ => 0⟩
+
+variable (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+noncomputable def monitoredWorldStep (input : OracleWorld.Domain) (state : MonitoredState) :
+    SPMF (AdversaryStep (.inl input) × MonitoredState) :=
+  (fun result => (((result.1, signingBoundaryTrace parameter input result.1), hashObservationTrace input result.1),
+    (result.2, certificateMonitorUpdate (monitorKey parameter root) budget required stopAfter (.inl input) (monitorView state) 0
+      (proposalOfWorldResult parameter input (result.1, result.2.1))))) <$>
+    cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot (worldProgram parameter labels input) state.1
+
+noncomputable def monitoredSignStep (message : Message) (state : MonitoredState) :
+    SPMF (AdversaryStep (.inr message) × MonitoredState) :=
+  (liftM (signingAnnotation (monitorKey parameter root) budget message (monitorView state)) : SPMF _) >>= fun annotation =>
+    (fun result => (((result.1.1.1, result.1.2), 1),
+      (result.2, certificateMonitorUpdate (monitorKey parameter root) budget required stopAfter (.inr message) (monitorView state) annotation.1
+        (proposalOfSigningRecord message result.1 result.2.1 (result.1.1.2.elim annotation.2 Prod.fst))))) <$>
+      cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot (signingProgram message) state.1
+
+noncomputable def monitoredStep : (input : (OracleWorld + SigningSpec).Domain) → MonitoredState →
+    SPMF (AdversaryStep input × MonitoredState)
+  | .inl input, state => monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state
+  | .inr message, state => monitoredSignStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter message state
+
+theorem monitoredStep_erasure (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState) :
+    (fun result => (result.1, result.2.1)) <$>
+      monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state =
+      forcedAdversaryStep parameter root otsSecret labels inputs hencoding selections rows dummy slot input state.1 := by
+  cases input with
+  | inl input =>
+      rw [monitoredStep, monitoredWorldStep, forcedAdversaryStep_world, Functor.map_map]
+  | inr message =>
+      rw [monitoredStep, monitoredSignStep, forcedAdversaryStep_sign, map_bind]
+      refine (RetainedObservation.bind_congr _ _ _ (fun annotation _ => ?_)).trans (RetainedObservation.lift_bind_const _ _)
+      rw [Functor.map_map]
+
+/-! ### Monitored runs -/
+
+noncomputable def monitoredRun {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result) :
+    MonitoredState → SPMF ((((Result × QueryLog SigningSpec) × SigningBoundaryTrace) × Trace) × MonitoredState) :=
+  OracleComp.construct (fun value state => pure ((((value, []), 1), 1), state))
+    (fun input _ next state =>
+      monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state >>= fun step =>
+        (fun tail => (combineStep input step.1 tail.1, tail.2)) <$> next step.1.1.1 step.2) computation
+
+theorem monitoredRun_pure {Result : Type} (value : Result) (state : MonitoredState) :
+    monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter (pure value) state =
+      pure ((((value, []), 1), 1), state) := rfl
+
+theorem monitoredRun_query_bind {Result : Type} (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Result) (state : MonitoredState) :
+    monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      (liftM ((OracleWorld + SigningSpec).query input) >>= next) state =
+      (monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state >>= fun step =>
+        (fun tail => (combineStep input step.1 tail.1, tail.2)) <$>
+          monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+            (next step.1.1.1) step.2) := by
+  rw [monitoredRun, OracleComp.construct_query_bind]
+  rfl
+
+theorem monitoredRun_erasure {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result) (state : MonitoredState) :
+    (fun result => (result.1, result.2.1)) <$>
+      monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter computation state =
+      cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot (adversaryRun parameter labels computation) state.1 := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => rw [monitoredRun_pure, cachedForcedRun_adversaryRun_pure, map_pure]
+  | query_bind input next ih =>
+      rw [monitoredRun_query_bind, cachedForcedRun_adversaryRun_query_bind, map_bind, ← monitoredStep_erasure, bind_map_left]
+      apply congrArg (_ >>= ·)
+      funext step
+      rw [Functor.map_map, ← ih step.1.1.1 step.2, Functor.map_map]
+
+noncomputable def monitoredWorldRun {Result : Type} (computation : OracleComp OracleWorld Result) :
+    MonitoredState → SPMF (((Result × SigningBoundaryTrace) × Trace) × MonitoredState) :=
+  OracleComp.construct (fun value state => pure (((value, 1), 1), state))
+    (fun input _ next state =>
+      monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state >>= fun step =>
+        (fun tail => (((tail.1.1.1, step.1.1.2 * tail.1.1.2), step.1.2 * tail.1.2), tail.2)) <$> next step.1.1.1 step.2) computation
+
+theorem monitoredWorldRun_pure {Result : Type} (value : Result) (state : MonitoredState) :
+    monitoredWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter (pure value) state =
+      pure (((value, 1), 1), state) := rfl
+
+theorem monitoredWorldRun_query_bind {Result : Type} (input : OracleWorld.Domain)
+    (next : OracleWorld.Range input → OracleComp OracleWorld Result) (state : MonitoredState) :
+    monitoredWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      (liftM (OracleWorld.query input) >>= next) state =
+      (monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state >>= fun step =>
+        (fun tail => (((tail.1.1.1, step.1.1.2 * tail.1.1.2), step.1.2 * tail.1.2), tail.2)) <$>
+          monitoredWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+            (next step.1.1.1) step.2) := by
+  rw [monitoredWorldRun, OracleComp.construct_query_bind]
+  rfl
+
+theorem traced_map {First Result : Type} (function : First → Result) (computation : OracleComp OracleWorld First) :
+    QueryPause.traced hashObservationTrace (function <$> computation) =
+      (fun result => (function result.1, result.2)) <$> QueryPause.traced hashObservationTrace computation := by
+  simp only [QueryPause.traced, simulateQ_map, WriterT.run_map]
+
+noncomputable def tracedWorldProgram {Result : Type} (computation : OracleComp OracleWorld Result) :
+    OracleComp World ((Result × SigningBoundaryTrace) × Trace) :=
+  simulateQ (worldProgram parameter labels) (QueryPause.traced hashObservationTrace (boundaryComputation parameter computation))
+
+theorem tracedWorldProgram_pure {Result : Type} (value : Result) :
+    tracedWorldProgram parameter labels (pure value) = pure ((value, 1), 1) := by
+  simp only [tracedWorldProgram, boundaryComputation, simulateQ_pure, WriterT.run_pure, QueryPause.traced_pure]
+
+theorem tracedWorldProgram_query_bind {Result : Type} (input : OracleWorld.Domain)
+    (next : OracleWorld.Range input → OracleComp OracleWorld Result) :
+    tracedWorldProgram parameter labels (liftM (OracleWorld.query input) >>= next) =
+      (worldProgram parameter labels input >>= fun answer =>
+        (fun tail => ((tail.1.1, signingBoundaryTrace parameter input answer * tail.1.2), hashObservationTrace input answer * tail.2)) <$>
+          tracedWorldProgram parameter labels (next answer)) := by
+  simp only [tracedWorldProgram, ResidualByteFrontend.boundaryComputation_query_bind, QueryPause.traced_query_bind, traced_map,
+    simulateQ_bind, simulateQ_spec_query, simulateQ_map, Functor.map_map]
+
+theorem verifyProgram_eq_traced (forgery : Forgery) :
+    verifyProgram parameter root labels forgery =
+      tracedWorldProgram parameter labels (liftM (verify ⟨root, parameter⟩ forgery.message forgery.signature : OracleComp HashSpec Bool)) := rfl
+
+theorem monitoredWorldStep_erasure (input : OracleWorld.Domain) (state : MonitoredState) :
+    (fun result => (result.1, result.2.1)) <$>
+      monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state =
+      (fun result => (((result.1, signingBoundaryTrace parameter input result.1), hashObservationTrace input result.1), result.2)) <$>
+        cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot (worldProgram parameter labels input) state.1 := by
+  rw [monitoredWorldStep, Functor.map_map]
+
+theorem cachedForcedRun_tracedWorldProgram_query_bind {Result : Type} (input : OracleWorld.Domain)
+    (next : OracleWorld.Range input → OracleComp OracleWorld Result) (state : CachedState) :
+    cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+      (tracedWorldProgram parameter labels (liftM (OracleWorld.query input) >>= next)) state =
+      (((fun result => (((result.1, signingBoundaryTrace parameter input result.1), hashObservationTrace input result.1), result.2)) <$>
+        cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot (worldProgram parameter labels input) state) >>=
+        fun step => (fun tail => (((tail.1.1.1, step.1.1.2 * tail.1.1.2), step.1.2 * tail.1.2), tail.2)) <$>
+          cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+            (tracedWorldProgram parameter labels (next step.1.1.1)) step.2) := by
+  rw [tracedWorldProgram_query_bind, cachedForcedRun_bind, bind_map_left]
+  apply congrArg (_ >>= ·)
+  funext step
+  rw [cachedForcedRun_map]
+
+theorem monitoredWorldRun_erasure {Result : Type} (computation : OracleComp OracleWorld Result) (state : MonitoredState) :
+    (fun result => (result.1, result.2.1)) <$>
+      monitoredWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter computation state =
+      cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+        (tracedWorldProgram parameter labels computation) state.1 := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => rw [monitoredWorldRun_pure, tracedWorldProgram_pure, cachedForcedRun_pure, map_pure]
+  | query_bind input next ih =>
+      rw [monitoredWorldRun_query_bind, cachedForcedRun_tracedWorldProgram_query_bind, map_bind, ← monitoredWorldStep_erasure,
+        bind_map_left]
+      apply congrArg (_ >>= ·)
+      funext step
+      rw [Functor.map_map, ← ih step.1.1.1 step.2, Functor.map_map]
+
+noncomputable def monitoredCompletedRun (adversary : Adversary) (state : MonitoredState) : SPMF (Completed × MonitoredState) :=
+  monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+    (adversary.main ⟨root, parameter⟩) state >>= fun before =>
+    (fun checked => ((before.1, checked.1), checked.2)) <$>
+      monitoredWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        (liftM (verify ⟨root, parameter⟩ before.1.1.1.1.message before.1.1.1.1.signature : OracleComp HashSpec Bool)) before.2
+
+theorem monitoredCompletedRun_erasure (adversary : Adversary) (state : MonitoredState) :
+    (fun result => (result.1, result.2.1)) <$>
+      monitoredCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter adversary state =
+      cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+        (completedRun parameter root labels adversary) state.1 := by
+  rw [monitoredCompletedRun, completedRun, cachedForcedRun_bind, map_bind, ← monitoredRun_erasure, bind_map_left]
+  apply congrArg (_ >>= ·)
+  funext before
+  rw [cachedForcedRun_bind, Functor.map_map, verifyProgram_eq_traced, ← monitoredWorldRun_erasure, bind_map_left]
+  simp only [cachedForcedRun_pure, map_eq_bind_pure_comp, Function.comp_def]
+  rfl
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessMonitoredValid.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessMonitoredValid.lean
new file mode 100644
index 000000000..bb934e66b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessMonitoredValid.lean
@@ -0,0 +1,358 @@
+import SphincsSecurity.Proof.Forced.FtsGuessMonitoredStep
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec UniformTableCompletion OtsContactTrace
+open FtsGuessSigning (Coordinate)
+open SecretGuessObservation (State forcedTrial environment)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  publicDigestLoop canonicalGraphRoot canonicalGraphInput hashInputs UniformTableCompletion.complete
+
+variable (parameter : PublicParameter) (root : Digest)
+  (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+  (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+  (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (dummy : OtsReferenceWords) (slot : Nat)
+
+/-! ### The cached forced run is a probability law -/
+
+theorem evalDist_probComp_lift {Result : Type} (computation : ProbComp Result) :
+    𝒟[computation] = (liftM (liftM computation : PMF Result) : SPMF Result) := by
+  apply SPMF.ext
+  intro result
+  rw [SPMF.liftM_apply, ← PMF.probOutput_eq_apply]
+  rfl
+
+theorem probComp_bind_const {Result Other : Type} (computation : ProbComp Result) (after : SPMF Other) :
+    (𝒟[computation] >>= fun _ => after) = after := by
+  rw [evalDist_probComp_lift]
+  exact RetainedObservation.lift_bind_const _ _
+
+theorem cachedSeedRun_seedLift_query_bind_const {Other : Type} (input : (SeedSpec inputs).Domain)
+    (cache : QueryCache HashSpec) (after : SPMF Other) :
+    (cachedSeedRun inputs (seedLift inputs input) cache >>= fun _ => after) = after := by
+  cases input with
+  | inl input =>
+      simp only [cachedSeedRun, seedLift, simulateQ_spec_query, cachedSeedImpl, StateT.run_mk, forcedSeedAuxiliary,
+        bind_map_left]
+      exact probComp_bind_const _ after
+  | inr input =>
+      simp only [cachedSeedRun, seedLift, simulateQ_spec_query, cachedSeedImpl, StateT.run_mk]
+      exact probComp_bind_const _ after
+
+theorem cachedSeedRun_seedLift_bind_const {Result Other : Type} (computation : OracleComp (SeedSpec inputs) Result)
+    (cache : QueryCache HashSpec) (after : SPMF Other) :
+    (cachedSeedRun inputs (simulateQ (seedLift inputs) computation) cache >>= fun _ => after) = after := by
+  induction computation using OracleComp.inductionOn generalizing cache with
+  | pure value => rw [simulateQ_pure, cachedSeedRun_pure, pure_bind]
+  | query_bind input next ih =>
+      rw [simulateQ_bind, simulateQ_spec_query, cachedSeedRun_bind, bind_assoc]
+      simp only [ih]
+      exact cachedSeedRun_seedLift_query_bind_const inputs input cache after
+
+theorem cachedAuxiliary_bind_const {Other : Type} (input : Auxiliary.Domain) (cache : QueryCache HashSpec)
+    (after : SPMF Other) :
+    (cachedAuxiliary parameter root otsSecret labels inputs hencoding selections rows dummy input cache >>= fun _ => after) =
+      after :=
+  cachedSeedRun_seedLift_bind_const inputs _ cache after
+
+theorem forcedTrial_bind_const {Other : Type} (state : State Coordinate Digest PUnit)
+    (ha : ∀ coordinate, (state.allowed coordinate).Nonempty) (coordinate : Coordinate) (candidate : Digest)
+    (after : SPMF Other) :
+    (forcedTrial slot state coordinate candidate >>= fun _ => after) = after := by
+  by_cases he : SecretGuessObservation.EligibleAt slot state coordinate candidate
+  · rw [forcedTrial, if_pos he, pure_bind]
+  · rw [forcedTrial, if_neg he, SecretGuessObservation.trial, bind_assoc]
+    simp only [pure_bind]
+    rw [complete_of_nonempty _ ha]
+    exact RetainedObservation.lift_bind_const _ _
+
+theorem cell_bind_const {Other : Type} (allowed : Finset Digest) (ha : allowed.Nonempty) (after : SPMF Other) :
+    (cell allowed >>= fun _ => after) = after := by
+  rw [cell, dif_pos ha]
+  exact RetainedObservation.lift_bind_const _ _
+
+theorem cachedForcedImpl_bind_const {Other : Type} (input : World.Domain) (state : CachedState)
+    (ha : ∀ coordinate, (state.2.allowed coordinate).Nonempty) (after : SPMF Other) :
+    ((cachedForcedImpl parameter root otsSecret labels inputs hencoding selections rows dummy slot input).run state >>=
+      fun _ => after) = after := by
+  cases input with
+  | inl input =>
+      simp only [cachedForcedImpl, StateT.run_mk, bind_map_left]
+      exact cachedAuxiliary_bind_const parameter root otsSecret labels inputs hencoding selections rows dummy input state.1 after
+  | inr input =>
+      cases input with
+      | inl probe =>
+          rcases probe with ⟨coordinate, candidate⟩
+          simp only [cachedForcedImpl, StateT.run_mk, bind_map_left]
+          exact forcedTrial_bind_const slot state.2 ha coordinate candidate after
+      | inr coordinate =>
+          simp only [cachedForcedImpl, StateT.run_mk, bind_map_left]
+          exact cell_bind_const _ (ha coordinate) after
+
+theorem cachedForcedImpl_nonempty (input : World.Domain) (state : CachedState)
+    (ha : ∀ coordinate, (state.2.allowed coordinate).Nonempty) (result : World.Range input × CachedState)
+    (hr : (cachedForcedImpl parameter root otsSecret labels inputs hencoding selections rows dummy slot input).run state result ≠ 0) :
+    ∀ coordinate, (result.2.2.allowed coordinate).Nonempty := by
+  rw [← cachedForcedRun_query] at hr
+  exact cachedForcedRun_nonempty parameter root otsSecret labels inputs hencoding selections rows dummy slot
+    (liftM (World.query input)) state.1 state.2 ha result hr
+
+theorem cachedForcedRun_bind_const {Result Other : Type} (computation : OracleComp World Result) (state : CachedState)
+    (ha : ∀ coordinate, (state.2.allowed coordinate).Nonempty) (after : SPMF Other) :
+    (cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot computation state >>=
+      fun _ => after) = after := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => rw [cachedForcedRun_pure, pure_bind]
+  | query_bind input next ih =>
+      rw [cachedForcedRun_query_bind, bind_assoc]
+      rw [RetainedObservation.bind_congr _ _ (fun _ => after) (fun result hr =>
+        ih result.1 result.2 (cachedForcedImpl_nonempty parameter root otsSecret labels inputs hencoding selections rows dummy slot
+          input state ha result hr))]
+      exact cachedForcedImpl_bind_const parameter root otsSecret labels inputs hencoding selections rows dummy slot input state ha after
+
+theorem tsum_cachedForcedRun_eq_one {Result : Type} (computation : OracleComp World Result) (state : CachedState)
+    (ha : ∀ coordinate, (state.2.allowed coordinate).Nonempty) :
+    (∑' result, Pr[= result | cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+      computation state]) = 1 := by
+  have h := congrArg (fun law : SPMF Unit => Pr[= () | law])
+    (cachedForcedRun_bind_const parameter root otsSecret labels inputs hencoding selections rows dummy slot computation state ha (pure ()))
+  simpa only [probOutput_bind_eq_tsum, probOutput_pure_self, mul_one] using h
+
+/-! ### Cached-state forms of the forced-run lemmas -/
+
+theorem cachedSigning_mem_support_sign' (message : Message) (state : CachedState)
+    (ha : ∀ coordinate, (state.2.allowed coordinate).Nonempty)
+    (hauxiliary : ∀ seed : inputs → HashOutput,
+      (⟨selections, rows, seed⟩ : ReferenceAuxiliary inputs) ∈ (referenceAuxiliarySample inputs).support)
+    (result : ((Option Signature × Option FewTimeView) × SigningBoundaryTrace) × CachedState)
+    (hr : cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot (signingProgram message) state result ≠ 0)
+    (secrets : Coordinate → Digest) (hsecrets : complete result.2.2.allowed secrets ≠ 0) :
+    result.1.1.1 ∈ support (sign ⟨parameter, root, otsSecret, FtsGuessSigning.secretTable.symm secrets⟩ message) := by
+  rcases state with ⟨cache, guess⟩
+  exact cachedSigning_mem_support_sign parameter root otsSecret labels inputs hencoding selections rows dummy slot message cache guess ha
+    hauxiliary result hr secrets hsecrets
+
+theorem cachedForcedRun_signingProgram' (message : Message) (state : CachedState)
+    (ha : ∀ coordinate, (state.2.allowed coordinate).Nonempty)
+    (hinputs : hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs)
+    (auxiliary : QueryImpl Auxiliary ProbComp) :
+    cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot (signingProgram message) state =
+      (complete state.2.allowed >>= fun secrets =>
+        (fun result => (completePublicSigningRecord (fun index tree leaf => secrets (index, tree, leaf)) result.1,
+          (result.2, FtsGuessSigning.completedState (environment auxiliary) secrets result.1 state.2))) <$>
+          𝒟[(simulateQ romImpl (Prod.fst <$> ResidualByteFrontend.publicSigningWork parameter root (known otsSecret labels)
+            (referenceFamilyWords selections dummy) selections message)).run state.1]) := by
+  rcases state with ⟨cache, guess⟩
+  exact cachedForcedRun_signingProgram parameter root otsSecret labels inputs hencoding selections rows dummy slot message cache guess ha
+    hinputs auxiliary
+
+theorem cachedForcedRun_world_unif' (sample : unifSpec.Domain) (state : CachedState) :
+    cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+      (worldProgram parameter labels (.inl sample)) state =
+      (fun answer => (answer, state)) <$> 𝒟[(liftM (unifSpec.query sample) : ProbComp _)] := by
+  rcases state with ⟨cache, guess⟩
+  exact cachedForcedRun_world_unif parameter root otsSecret labels inputs hencoding selections rows dummy slot sample cache guess
+
+theorem cachedForcedRun_world_message' (input : HashInput) (hin : input ∈ inputs)
+    (hmessage : FtsProbeSimulation.MessageHashInput parameter input) (state : CachedState) :
+    cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+      (worldProgram parameter labels (.inr input)) state =
+      (fun result => (result.1, (result.2, state.2))) <$> 𝒟[(romImpl (.inr input)).run state.1] := by
+  rcases state with ⟨cache, guess⟩
+  exact cachedForcedRun_world_message parameter root otsSecret labels inputs hencoding selections rows dummy slot input hin hmessage
+    cache guess
+
+theorem cachedForcedRun_world_hash_support' (input : HashInput) (state : CachedState) (result : HashOutput × CachedState)
+    (hr : cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+      (worldProgram parameter labels (.inr input)) state result ≠ 0) :
+    (∀ other, other ≠ input → result.2.1 other = state.1 other) ∧ state.1 ≤ result.2.1 ∧
+      QueryCache.enncard result.2.1 ≤ QueryCache.enncard state.1 + 1 := by
+  rcases state with ⟨cache, guess⟩
+  exact cachedForcedRun_world_hash_support parameter root otsSecret labels inputs hencoding selections rows dummy slot input cache guess
+    result hr
+
+/-! ### Valid monitored states -/
+
+def Valid (state : MonitoredState) : Prop := ∀ coordinate, (state.1.2.allowed coordinate).Nonempty
+
+variable (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+theorem monitoredStep_forced (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState)
+    (result : AdversaryStep input × MonitoredState)
+    (hresult : monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      input state result ≠ 0) :
+    forcedAdversaryStep parameter root otsSecret labels inputs hencoding selections rows dummy slot input state.1
+      (result.1, result.2.1) ≠ 0 := by
+  have h := map_nonzero_of _ (fun result => (result.1, result.2.1)) result hresult
+  rwa [monitoredStep_erasure] at h
+
+theorem monitoredStep_valid (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState) (hvalid : Valid state)
+    (result : AdversaryStep input × MonitoredState)
+    (hresult : monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      input state result ≠ 0) : Valid result.2 := by
+  have h := monitoredStep_forced parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+    input state result hresult
+  rw [forcedAdversaryStep] at h
+  exact cachedForcedRun_nonempty parameter root otsSecret labels inputs hencoding selections rows dummy slot _ state.1.1 state.1.2 hvalid
+    _ h
+
+theorem monitoredStep_allowed_subset (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState)
+    (result : AdversaryStep input × MonitoredState)
+    (hresult : monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      input state result ≠ 0) :
+    ∀ coordinate, result.2.1.2.allowed coordinate ⊆ state.1.2.allowed coordinate := by
+  have h := monitoredStep_forced parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+    input state result hresult
+  rw [forcedAdversaryStep] at h
+  exact cachedForcedRun_allowed_subset parameter root otsSecret labels inputs hencoding selections rows dummy slot _ state.1.1 state.1.2
+    _ h
+
+theorem monitoredStep_bind_const {Other : Type} (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState)
+    (hvalid : Valid state) (after : SPMF Other) :
+    (monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state >>=
+      fun _ => after) = after := by
+  have h := cachedForcedRun_bind_const parameter root otsSecret labels inputs hencoding selections rows dummy slot
+    ((adversaryImpl parameter labels input).run.run) state.1 hvalid after
+  rw [← forcedAdversaryStep, ← monitoredStep_erasure, bind_map_left] at h
+  exact h
+
+theorem tsum_monitoredStep_eq_one (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState) (hvalid : Valid state) :
+    (∑' result, Pr[= result | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+      stopAfter input state]) = 1 := by
+  have h := congrArg (fun law : SPMF Unit => Pr[= () | law])
+    (monitoredStep_bind_const parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      input state hvalid (pure ()))
+  simpa only [probOutput_bind_eq_tsum, probOutput_pure_self, mul_one] using h
+
+theorem monitoredWorldStep_bind_const {Other : Type} (input : OracleWorld.Domain) (state : MonitoredState)
+    (hvalid : Valid state) (after : SPMF Other) :
+    (monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state >>=
+      fun _ => after) = after :=
+  monitoredStep_bind_const parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+    (.inl input) state hvalid after
+
+/-! ### Input coverage along the run -/
+
+def CoveredRun (computation : OracleComp (OracleWorld + SigningSpec) Forgery) (state : MonitoredState) : Prop :=
+  ∀ secrets : Coordinate → Digest, complete state.1.2.allowed secrets ≠ 0 →
+    coveredInputs ⟨parameter, root, otsSecret, FtsGuessSigning.secretTable.symm secrets⟩ computation ⊆ inputs
+
+theorem exists_complete_ne_zero (allowed : Coordinate → Finset Digest) (ha : ∀ coordinate, (allowed coordinate).Nonempty) :
+    ∃ secrets, complete allowed secrets ≠ 0 :=
+  ⟨fun coordinate => (ha coordinate).choose, complete_ne_zero_of_mem allowed _ (fun coordinate => (ha coordinate).choose_spec)⟩
+
+theorem complete_ne_zero_of_subset (before after : Coordinate → Finset Digest) (hsubset : ∀ coordinate, after coordinate ⊆ before coordinate)
+    (secrets : Coordinate → Digest) (hsecrets : complete after secrets ≠ 0) : complete before secrets ≠ 0 :=
+  complete_ne_zero_of_mem before secrets (fun coordinate => hsubset coordinate (mem_of_complete_ne_zero after secrets hsecrets coordinate))
+
+theorem covered_world_mem (input : HashInput) (next : HashOutput → OracleComp (OracleWorld + SigningSpec) Forgery)
+    (state : MonitoredState) (hvalid : Valid state)
+    (hcovered : CoveredRun parameter root otsSecret inputs (liftM ((OracleWorld + SigningSpec).query (.inl (.inr input))) >>= next) state) :
+    input ∈ inputs := by
+  obtain ⟨secrets, hsecrets⟩ := exists_complete_ne_zero state.1.2.allowed hvalid
+  exact hcovered secrets hsecrets (coveredInputs_world _ input next)
+
+set_option linter.constructorNameAsVariable false in
+theorem covered_world_inputs (input : OracleWorld.Domain) (next : OracleWorld.Range input → OracleComp (OracleWorld + SigningSpec) Forgery)
+    (state : MonitoredState) (hvalid : Valid state)
+    (hcovered : CoveredRun parameter root otsSecret inputs (liftM ((OracleWorld + SigningSpec).query (.inl input)) >>= next) state) :
+    hashInputs (liftM (OracleWorld.query input)) ⊆ inputs := by
+  cases input with
+  | inl sample =>
+      rw [← bind_pure (liftM (OracleWorld.query (.inl sample))), hashInputs_query_bind]
+      intro row hrow
+      rw [Finset.mem_union, Finset.mem_biUnion] at hrow
+      rcases hrow with hrow | ⟨_, _, hrow⟩ <;> simp only [hashInputs_pure, Finset.notMem_empty] at hrow
+  | inr hash =>
+      rw [← bind_pure (liftM (OracleWorld.query (.inr hash))), hashInputs_query_bind]
+      intro row hrow
+      rw [Finset.mem_union, Finset.mem_biUnion] at hrow
+      rcases hrow with hrow | ⟨_, _, hrow⟩
+      · rw [Finset.mem_singleton] at hrow
+        subst row
+        exact covered_world_mem parameter root otsSecret inputs hash next state hvalid hcovered
+      · simp only [hashInputs_pure, Finset.notMem_empty] at hrow
+
+theorem covered_sign_digest (message : Message) (next : Option Signature → OracleComp (OracleWorld + SigningSpec) Forgery)
+    (state : MonitoredState) (hvalid : Valid state)
+    (hcovered : CoveredRun parameter root otsSecret inputs (liftM ((OracleWorld + SigningSpec).query (.inr message)) >>= next) state) :
+    hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs := by
+  obtain ⟨secrets, hsecrets⟩ := exists_complete_ne_zero state.1.2.allowed hvalid
+  let key : SecretKey := ⟨parameter, root, otsSecret, FtsGuessSigning.secretTable.symm secrets⟩
+  have h := (coveredInputs_sign key message next).trans (hcovered secrets hsecrets)
+  rw [← publicDigestLoop_eq key message digestAttemptLimit] at h
+  exact h
+
+theorem covered_world_next (input : OracleWorld.Domain) (next : OracleWorld.Range input → OracleComp (OracleWorld + SigningSpec) Forgery)
+    (state : MonitoredState)
+    (hcovered : CoveredRun parameter root otsSecret inputs (liftM ((OracleWorld + SigningSpec).query (.inl input)) >>= next) state)
+    (result : AdversaryStep (.inl input) × MonitoredState)
+    (hresult : monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      (.inl input) state result ≠ 0) :
+    CoveredRun parameter root otsSecret inputs (next result.1.1.1) result.2 := by
+  intro secrets hsecrets
+  have hbefore := complete_ne_zero_of_subset _ _
+    (monitoredStep_allowed_subset parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      (.inl input) state result hresult) secrets hsecrets
+  exact (coveredInputs_world_next _ input next result.1.1.1).trans (hcovered secrets hbefore)
+
+theorem covered_sign_next (message : Message) (next : Option Signature → OracleComp (OracleWorld + SigningSpec) Forgery)
+    (state : MonitoredState) (hvalid : Valid state)
+    (hauxiliary : ∀ seed : inputs → HashOutput,
+      (⟨selections, rows, seed⟩ : ReferenceAuxiliary inputs) ∈ (referenceAuxiliarySample inputs).support)
+    (hcovered : CoveredRun parameter root otsSecret inputs (liftM ((OracleWorld + SigningSpec).query (.inr message)) >>= next) state)
+    (result : AdversaryStep (.inr message) × MonitoredState)
+    (hresult : monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      (.inr message) state result ≠ 0) :
+    CoveredRun parameter root otsSecret inputs (next result.1.1.1) result.2 := by
+  intro secrets hsecrets
+  have hbefore := complete_ne_zero_of_subset _ _
+    (monitoredStep_allowed_subset parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      (.inr message) state result hresult) secrets hsecrets
+  have hforced := monitoredStep_forced parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+    (.inr message) state result hresult
+  rw [forcedAdversaryStep_sign] at hforced
+  obtain ⟨raw, hraw, heq⟩ := map_nonzero_source' _ _ _ hforced
+  have hstate : result.2.1 = raw.2 := congrArg Prod.snd heq
+  have hsignature : result.1.1.1 = raw.1.1.1 := congrArg (fun r => r.1.1.1) heq
+  rw [hstate] at hsecrets
+  have hsupport := cachedSigning_mem_support_sign' parameter root otsSecret labels inputs hencoding selections rows dummy slot message
+    state.1 hvalid hauxiliary raw hraw secrets hsecrets
+  rw [hsignature]
+  exact (coveredInputs_sign_next _ message next raw.1.1.1 hsupport).trans (hcovered secrets hbefore)
+
+theorem covered_pure (forgery : Forgery) (state : MonitoredState) (hvalid : Valid state)
+    (hcovered : CoveredRun parameter root otsSecret inputs (pure forgery) state) :
+    hashInputs (liftM (verify ⟨root, parameter⟩ forgery.message forgery.signature : OracleComp HashSpec Bool) :
+      OracleComp OracleWorld Bool) ⊆ inputs := by
+  obtain ⟨secrets, hsecrets⟩ := exists_complete_ne_zero state.1.2.allowed hvalid
+  have h := hcovered secrets hsecrets
+  rwa [coveredInputs_pure] at h
+
+theorem hashInputs_world_next {Result : Type} (input : OracleWorld.Domain)
+    (next : OracleWorld.Range input → OracleComp OracleWorld Result) (answer : OracleWorld.Range input) :
+    hashInputs (next answer) ⊆ hashInputs (liftM (OracleWorld.query input) >>= next) := by
+  rw [hashInputs_query_bind]
+  intro row hrow
+  rw [Finset.mem_union, Finset.mem_biUnion]
+  exact Or.inr ⟨answer, Finset.mem_univ _, hrow⟩
+
+theorem hashInputs_world_query {Result : Type} (input : OracleWorld.Domain)
+    (next : OracleWorld.Range input → OracleComp OracleWorld Result) :
+    hashInputs (liftM (OracleWorld.query input)) ⊆ hashInputs (liftM (OracleWorld.query input) >>= next) := by
+  intro row hrow
+  rw [hashInputs_query_bind, Finset.mem_union]
+  left
+  cases input with
+  | inl sample =>
+      exfalso
+      rw [← bind_pure (liftM (OracleWorld.query (.inl sample))), hashInputs_query_bind, Finset.mem_union, Finset.mem_biUnion] at hrow
+      rcases hrow with hrow | ⟨_, _, hrow⟩ <;> simp only [hashInputs_pure, Finset.notMem_empty] at hrow
+  | inr hash =>
+      rw [← bind_pure (liftM (OracleWorld.query (.inr hash))), hashInputs_query_bind, Finset.mem_union, Finset.mem_biUnion] at hrow
+      rcases hrow with hrow | ⟨_, _, hrow⟩
+      · exact hrow
+      · simp only [hashInputs_pure, Finset.notMem_empty] at hrow
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessNearAssembly.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessNearAssembly.lean
new file mode 100644
index 000000000..f728cbc58
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessNearAssembly.lean
@@ -0,0 +1,390 @@
+import SphincsSecurity.Proof.Forced.FtsGuessExceptionClassification
+import SphincsSecurity.Proof.Residual.RetainedResidualTerminalCoverage
+import SphincsSecurity.Proof.Fts.NearCertificateBound
+import SphincsSecurity.Proof.Forced.Security127SmallBudgetArithmetic
+/-!
+The forced FTS near-certificate game is bounded slot by slot. One forced run is monitored by the certificate monitor of the retained residual chain, with the keygen debit, the fixed-length proposal word and the prefix stop rule, exactly as the original certificate games were. A near certificate on an unstopped monitor is a banked certificate, so its probability is at most the expected creation cost, which the proposal-word martingale bounds by the budget times the average terminal certificate price. A stopped monitor is a cache exception or a prefix exception, each of which is rare. The bound `nearCertificateBound` sums the two over the fourteen omitted trees.
+-/
+
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec UniformTableCompletion OtsContactTrace ENNReal
+open FtsGuessSigning (Coordinate)
+open SecretGuessObservation (State initialState)
+open RetainedResidual (proposalStop signingInput)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  UniformTableCompletion.complete
+
+variable (parameter : PublicParameter) (root : Digest)
+  (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+  (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+  (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (dummy : OtsReferenceWords) (slot : Nat)
+  (hauxiliary : ∀ seed : inputs → HashOutput,
+    (⟨selections, rows, seed⟩ : ReferenceAuxiliary inputs) ∈ (referenceAuxiliarySample inputs).support)
+
+private theorem law_ne_zero_of_mem_support {α : Type} (law : SPMF α) (x : α) (h : x ∈ support law) : law x ≠ 0 :=
+  (mem_support_iff_evalDist_apply_ne_zero _ _).mp h
+
+private theorem pmf_mem_of_evalDist {Result : Type} (law : PMF Result) (result : Result)
+    (hresult : result ∈ support 𝒟[law]) : result ∈ law.support := by
+  change result ∈ (𝒟[law]).support at hresult
+  simpa only [PMF.evalDist_eq, SPMF.support_liftM] using hresult
+
+/-- The monitored start of a forced run: the empty cache, the fresh guess state and the keygen debit. -/
+abbrev nearStart (spent : Nat) (stopped : Bool) : MonitoredState :=
+  ((∅, initialState PUnit.unit), initialCertificateMonitor spent stopped)
+
+/-- The forced run of the whole near game for fixed sampled parameters. -/
+@[reducible] noncomputable def nearLaw (adversary : Adversary) : SPMF (Completed × CachedState) :=
+  cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot
+    (completedRun parameter root labels adversary) (∅, initialState PUnit.unit)
+
+/-- A near certificate whose covered trees omit exactly `omitted`. -/
+def NearCertificateOmitting (omitted : FtsTree) (result : Completed) : Prop :=
+  SigningTranscript.Valid result.1.1.1.2 ∧
+    TargetCertificateAt (monitorKey parameter root) (Finset.univ.erase omitted)
+      (hashRowsCache (result.1.1.2 * result.2.1.2).messageCalls, result.1.1.1.2)
+      (signingInput (monitorKey parameter root) result.1.1.1.1.message result.1.1.1.1.signature)
+
+theorem completedNearCertificate_exists (result : Completed) (hnear : completedNearCertificate parameter root result) :
+    ∃ omitted, NearCertificateOmitting parameter root omitted result := by
+  obtain ⟨hvalid, omitted, hcertificate⟩ := hnear
+  exact ⟨omitted, hvalid, hcertificate⟩
+
+theorem nearStart_valid (spent : Nat) (stopped : Bool) : Valid (nearStart spent stopped) :=
+  fun _ => Finset.univ_nonempty
+
+include hauxiliary in
+theorem near_alive_le (budget : Nat) (adversary : Adversary) (omitted : FtsTree) (spent : Nat) (stopped : Bool) (total : Nat)
+    (hbudget : budget ≤ 2 ^ 127) (hpool : stopped = false → 25313293 ≤ total)
+    (hcovered : CoveredRun parameter root otsSecret inputs (adversary.main ⟨root, parameter⟩) (nearStart spent stopped))
+    (hwork : ∀ result : Completed × CachedState,
+      nearLaw parameter root otsSecret labels inputs hencoding selections rows dummy slot adversary result ≠ 0 →
+        completedWork result.1 ≤ budget) :
+    Pr[fun result => NearCertificateOmitting parameter root omitted result.1 ∧ result.2.2.stopped = false |
+        monitoredCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget (Finset.univ.erase omitted)
+          (proposalStop (fun _ _ _ _ => false)) adversary (nearStart spent stopped)] ≤
+      (budget : ENNReal) *
+        terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice (Finset.univ.erase omitted)) [] := by
+  have hvalid := nearStart_valid spent stopped
+  have heraseMon : (fun result => (result.1, result.2.1)) <$>
+      monitoredCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget (Finset.univ.erase omitted)
+        (proposalStop (fun _ _ _ _ => false)) adversary (nearStart spent stopped) =
+      nearLaw parameter root otsSecret labels inputs hencoding selections rows dummy slot adversary :=
+    monitoredCompletedRun_erasure parameter root otsSecret labels inputs hencoding selections rows dummy slot budget (Finset.univ.erase omitted)
+      (proposalStop (fun _ _ _ _ => false)) adversary (nearStart spent stopped)
+  have herase : Prod.map id Prod.snd <$>
+      proposalCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget (Finset.univ.erase omitted)
+        (proposalStop (fun _ _ _ _ => false)) adversary ([], nearStart spent stopped) =
+      monitoredCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget (Finset.univ.erase omitted)
+        (proposalStop (fun _ _ _ _ => false)) adversary (nearStart spent stopped) :=
+    proposalCompletedRun_erasure parameter root otsSecret labels inputs hencoding selections rows dummy slot budget (Finset.univ.erase omitted)
+      (proposalStop (fun _ _ _ _ => false)) adversary ([], nearStart spent stopped)
+  have hcount : Pr[fun result => NearCertificateOmitting parameter root omitted result.1 ∧ result.2.2.stopped = false |
+      monitoredCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget (Finset.univ.erase omitted)
+        (proposalStop (fun _ _ _ _ => false)) adversary (nearStart spent stopped)] ≤
+      ∑' result, Pr[= result | monitoredCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+        (Finset.univ.erase omitted) (proposalStop (fun _ _ _ _ => false)) adversary (nearStart spent stopped)] *
+        certificateBankCount result.2.2.bank := by
+    apply probEvent_le_tsum_probOutput_mul_cost_of_mem_support
+    intro result hmem hevent
+    have hresult := law_ne_zero_of_mem_support _ _ hmem
+    obtain ⟨⟨_, hcertificate⟩, halive⟩ := hevent
+    exact monitoredCompletedRun_certificate_count parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+      (Finset.univ.erase omitted) (proposalStop (fun _ _ _ _ => false)) hauxiliary adversary spent stopped hcovered result hresult halive _
+      hcertificate
+  have hcost := expected_monitoredCompletedRun_count_le_creationCost parameter root otsSecret labels inputs hencoding selections rows dummy slot
+    budget (Finset.univ.erase omitted) (proposalStop (fun _ _ _ _ => false)) hauxiliary adversary spent stopped hcovered
+  have hinv : ProposalInvariant parameter root total ([], nearStart spent stopped) :=
+    certificateProposalInvariant_initial (monitorKey parameter root) total spent ∅ stopped hpool
+  have hmass := expected_proposalCompletedRun_creationCost_le_mass_terminalPotential parameter root otsSecret labels inputs hencoding
+    selections rows dummy slot budget (Finset.univ.erase omitted) (fun _ _ _ _ => false) hauxiliary total adversary ([], nearStart spent stopped)
+    hvalid hcovered hbudget hinv
+  have hmartingale := expected_proposalCompletedRun_terminalPotential parameter root otsSecret labels inputs hencoding selections rows dummy
+    slot budget (Finset.univ.erase omitted) (proposalStop (fun _ _ _ _ => false)) hauxiliary adversary ([], nearStart spent stopped) hvalid
+    hcovered total (terminalCertificatePrice (Finset.univ.erase omitted))
+  have hpoint : ∀ result : Completed × ProposalState,
+      Pr[= result | proposalCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+          (Finset.univ.erase omitted) (proposalStop (fun _ _ _ _ => false)) adversary ([], nearStart spent stopped)] *
+        (result.2.2.2.creationMass *
+          terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice (Finset.univ.erase omitted)) result.2.1) ≤
+      Pr[= result | proposalCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+          (Finset.univ.erase omitted) (proposalStop (fun _ _ _ _ => false)) adversary ([], nearStart spent stopped)] *
+        ((budget : ENNReal) *
+          terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice (Finset.univ.erase omitted)) result.2.1) := by
+    intro result
+    by_cases hzero : Pr[= result | proposalCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+        (Finset.univ.erase omitted) (proposalStop (fun _ _ _ _ => false)) adversary ([], nearStart spent stopped)] = 0
+    · rw [hzero, zero_mul, zero_mul]
+    · rw [SPMF.probOutput_eq_apply] at hzero
+      have hmon := map_nonzero_of _ (Prod.map id Prod.snd) result hzero
+      rw [herase] at hmon
+      have hmassle := monitoredCompletedRun_creationMass_le parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+        (Finset.univ.erase omitted) (proposalStop (fun _ _ _ _ => false)) hauxiliary adversary spent stopped hcovered _ hmon
+      have hlaw := map_nonzero_of _ (fun result => (result.1, result.2.1)) _ hmon
+      rw [heraseMon] at hlaw
+      have hwork' : completedWork result.1 ≤ budget := hwork _ hlaw
+      have hmassle' : result.2.2.2.creationMass ≤ (completedWork result.1 : ENNReal) := hmassle
+      exact mul_le_mul' le_rfl (mul_le_mul' (hmassle'.trans (by exact_mod_cast hwork')) le_rfl)
+  calc
+    _ ≤ _ := hcount
+    _ ≤ _ := hcost
+    _ = ∑' result, Pr[= result | proposalCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+        (Finset.univ.erase omitted) (proposalStop (fun _ _ _ _ => false)) adversary ([], nearStart spent stopped)] *
+        result.2.2.2.creationCost := by
+      rw [← herase, tsum_probOutput_map_mul]
+      simp only [Prod.map_snd]
+    _ ≤ ([], nearStart spent stopped).2.2.creationCost + _ := hmass
+    _ = ∑' result, Pr[= result | proposalCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+        (Finset.univ.erase omitted) (proposalStop (fun _ _ _ _ => false)) adversary ([], nearStart spent stopped)] *
+        (result.2.2.2.creationMass *
+          terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice (Finset.univ.erase omitted)) result.2.1) := by
+      simp only [nearStart, initialCertificateMonitor, zero_add]
+    _ ≤ _ := ENNReal.tsum_le_tsum hpoint
+    _ = (budget : ENNReal) * ∑' result, Pr[= result | proposalCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy
+        slot budget (Finset.univ.erase omitted) (proposalStop (fun _ _ _ _ => false)) adversary ([], nearStart spent stopped)] *
+        terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice (Finset.univ.erase omitted)) result.2.1 := by
+      rw [← ENNReal.tsum_mul_left]
+      apply tsum_congr
+      intro result
+      ring
+    _ = _ := by rw [hmartingale]
+
+include hauxiliary in
+theorem near_stopped_le (budget : Nat) (adversary : Adversary) (required : Finset FtsTree) (total : Nat) (hbudget : budget ≤ 2 ^ 127)
+    (hcovered : CoveredRun parameter root otsSecret inputs (adversary.main ⟨root, parameter⟩) (nearStart 1212415 (decide (total < 25313293))))
+    (hwork : ∀ result : Completed × CachedState,
+      nearLaw parameter root otsSecret labels inputs hencoding selections rows dummy slot adversary result ≠ 0 →
+        1212415 + completedWork result.1 ≤ budget) :
+    Pr[fun result => SigningTranscript.Valid result.1.1.1.1.2 ∧ result.2.2.stopped = true |
+        monitoredCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          (proposalStop (fun _ _ _ _ => false)) adversary (nearStart 1212415 (decide (total < 25313293)))] ≤
+      (if total < 25313293 then 1 else 0) + (budget : ENNReal) * certificateCacheExceptionRate + (2 ^ 700 : ENNReal)⁻¹ := by
+  by_cases hshort : total < 25313293
+  · rw [if_pos hshort]
+    exact probEvent_le_one.trans (le_self_add.trans le_self_add)
+  rw [if_neg hshort, zero_add]
+  have hstopped : decide (total < 25313293) = false := decide_eq_false hshort
+  have hvalid := nearStart_valid 1212415 (decide (total < 25313293))
+  have heraseMon : (fun result => (result.1, result.2.1)) <$>
+      monitoredCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        (proposalStop (fun _ _ _ _ => false)) adversary (nearStart 1212415 (decide (total < 25313293))) =
+      nearLaw parameter root otsSecret labels inputs hencoding selections rows dummy slot adversary :=
+    monitoredCompletedRun_erasure parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+      (proposalStop (fun _ _ _ _ => false)) adversary (nearStart 1212415 (decide (total < 25313293)))
+  have herase : (fun result => (result.1, result.2.1)) <$>
+      exceptionCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        (proposalStop (fun _ _ _ _ => false)) adversary (nearStart 1212415 (decide (total < 25313293)), (false, false)) =
+      monitoredCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        (proposalStop (fun _ _ _ _ => false)) adversary (nearStart 1212415 (decide (total < 25313293))) :=
+    exceptionCompletedRun_erasure parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+      (proposalStop (fun _ _ _ _ => false)) adversary (nearStart 1212415 (decide (total < 25313293)), (false, false))
+  have hsized : Sized (nearStart 1212415 (decide (total < 25313293))) :=
+    ⟨0, by
+      show QueryCache.enncard (∅ : QueryCache HashSpec) ≤ ((0 : Nat) : ENNReal)
+      rw [QueryCache.enncard_empty]
+      exact zero_le⟩
+  have hcons : Consistent parameter root (nearStart 1212415 (decide (total < 25313293))) := by
+    refine ⟨?_, ?_⟩
+    · show QueryCache.enncard (∅ : QueryCache HashSpec) ≤ ((1212415 : Nat) : ENNReal)
+      rw [QueryCache.enncard_empty]
+      exact zero_le
+    · intro entry hentry
+      exact (List.not_mem_nil hentry).elim
+  have halive : (nearStart 1212415 (decide (total < 25313293))).2.stopped = false := hstopped
+  have hwork' : ∀ result : Completed × ExceptionState,
+      exceptionCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        (proposalStop (fun _ _ _ _ => false)) adversary (nearStart 1212415 (decide (total < 25313293)), (false, false)) result ≠ 0 →
+        1212415 + completedWork result.1 ≤ budget := by
+    intro result hresult
+    have hmon := map_nonzero_of _ (fun result => (result.1, result.2.1)) result hresult
+    rw [herase] at hmon
+    have hlaw := map_nonzero_of _ (fun result => (result.1, result.2.1)) _ hmon
+    rw [heraseMon] at hlaw
+    exact hwork _ hlaw
+  rw [← herase, probEvent_map]
+  refine le_trans (probEvent_mono (q := fun result : Completed × ExceptionState => result.2.2.1 = true ∨ result.2.2.2 = true) ?_) ?_
+  · intro result hmem hevent
+    have hresult := law_ne_zero_of_mem_support _ _ hmem
+    obtain ⟨hvalidLog, hstoppedTrue⟩ := hevent
+    by_contra hflags
+    have hclean : result.2.2 = (false, false) := by
+      simp only [not_or, Bool.not_eq_true] at hflags
+      exact Prod.ext hflags.1 hflags.2
+    have hlog : result.1.1.1.1.2.length ≤ signatureLimit := hvalidLog
+    have hunstopped := exceptionCompletedRun_unstopped parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+      hauxiliary adversary (nearStart 1212415 (decide (total < 25313293)), (false, false)) hvalid hcovered hcons halive hbudget result hresult
+      (hwork' result hresult) (by simpa only [initialCertificateMonitor, List.length_nil, zero_add] using hlog) hclean
+    have hstoppedTrue' : result.2.1.2.stopped = true := hstoppedTrue
+    rw [hunstopped] at hstoppedTrue'
+    exact Bool.false_ne_true hstoppedTrue'
+  refine (probEvent_or_le _ _ _).trans (add_le_add ?_ ?_)
+  · refine (exceptionCompletedRun_cache_le parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+      (proposalStop (fun _ _ _ _ => false)) hauxiliary adversary (nearStart 1212415 (decide (total < 25313293)), (false, false)) hvalid hcovered
+      hsized).trans ?_
+    have hweight : cacheHistoryWeight parameter root (nearStart 1212415 (decide (total < 25313293)), (false, false)) = 0 := by
+      simp only [cacheHistoryWeight, Bool.false_eq_true, if_false]
+      exact certificateCacheExceptionWeight_initial _ _ (fun _ _ => rfl)
+    rw [hweight, zero_add]
+    apply mul_le_mul' ?_ le_rfl
+    calc
+      _ ≤ ∑' result, Pr[= result | monitoredCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+          required (proposalStop (fun _ _ _ _ => false)) adversary (nearStart 1212415 (decide (total < 25313293)))] * (budget : ENNReal) := by
+        apply ENNReal.tsum_le_tsum
+        intro result
+        by_cases hzero : Pr[= result | monitoredCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+            required (proposalStop (fun _ _ _ _ => false)) adversary (nearStart 1212415 (decide (total < 25313293)))] = 0
+        · rw [hzero, zero_mul, zero_mul]
+        · rw [SPMF.probOutput_eq_apply] at hzero
+          have hlaw := map_nonzero_of _ (fun result => (result.1, result.2.1)) result hzero
+          rw [heraseMon] at hlaw
+          have hbound : 1212415 + completedWork result.1 ≤ budget := hwork _ hlaw
+          exact mul_le_mul' le_rfl (by exact_mod_cast (show completedWork result.1 ≤ budget by omega))
+      _ ≤ _ := by
+        rw [ENNReal.tsum_mul_right]
+        exact mul_le_of_le_one_left' tsum_probOutput_le_one
+  · refine (exceptionCompletedRun_prefix_le parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+      (proposalStop (fun _ _ _ _ => false)) adversary (nearStart 1212415 (decide (total < 25313293)), (false, false)) (Nat.zero_le _)).trans ?_
+    simp only [prefixHistoryWeight, Bool.false_eq_true, if_false, initialCertificateMonitor, List.length_nil]
+    exact proposalPrefixWeight_initial_le
+
+include hauxiliary in
+theorem near_omitting_total_le (budget : Nat) (adversary : Adversary) (omitted : FtsTree) (total : Nat) (hbudget : budget ≤ 2 ^ 127)
+    (hcovered : CoveredRun parameter root otsSecret inputs (adversary.main ⟨root, parameter⟩) (nearStart 1212415 (decide (total < 25313293))))
+    (hwork : ∀ result : Completed × CachedState,
+      nearLaw parameter root otsSecret labels inputs hencoding selections rows dummy slot adversary result ≠ 0 →
+        1212415 + completedWork result.1 ≤ budget) :
+    Pr[fun result => NearCertificateOmitting parameter root omitted result.1 |
+        nearLaw parameter root otsSecret labels inputs hencoding selections rows dummy slot adversary] ≤
+      (budget : ENNReal) *
+          terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice (Finset.univ.erase omitted)) [] +
+        ((if total < 25313293 then 1 else 0) + (budget : ENNReal) * certificateCacheExceptionRate + (2 ^ 700 : ENNReal)⁻¹) := by
+  have heraseMon : (fun result => (result.1, result.2.1)) <$>
+      monitoredCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget (Finset.univ.erase omitted)
+        (proposalStop (fun _ _ _ _ => false)) adversary (nearStart 1212415 (decide (total < 25313293))) =
+      nearLaw parameter root otsSecret labels inputs hencoding selections rows dummy slot adversary :=
+    monitoredCompletedRun_erasure parameter root otsSecret labels inputs hencoding selections rows dummy slot budget (Finset.univ.erase omitted)
+      (proposalStop (fun _ _ _ _ => false)) adversary (nearStart 1212415 (decide (total < 25313293)))
+  rw [← heraseMon, probEvent_map]
+  refine le_trans (probEvent_mono (q := fun result : Completed × MonitoredState =>
+    (NearCertificateOmitting parameter root omitted result.1 ∧ result.2.2.stopped = false) ∨
+      (SigningTranscript.Valid result.1.1.1.1.2 ∧ result.2.2.stopped = true)) ?_) ?_
+  · intro result _ hevent
+    have hnear : NearCertificateOmitting parameter root omitted result.1 := hevent
+    cases hstopped : result.2.2.stopped
+    · exact Or.inl ⟨hnear, rfl⟩
+    · exact Or.inr ⟨hnear.1, rfl⟩
+  refine (probEvent_or_le _ _ _).trans (add_le_add ?_ ?_)
+  · exact near_alive_le parameter root otsSecret labels inputs hencoding selections rows dummy slot hauxiliary budget adversary omitted 1212415 _
+      total hbudget (fun h => Nat.le_of_not_lt (of_decide_eq_false h)) hcovered (fun result h => by have := hwork result h; omega)
+  · exact near_stopped_le parameter root otsSecret labels inputs hencoding selections rows dummy slot hauxiliary budget adversary
+      (Finset.univ.erase omitted) total hbudget hcovered hwork
+
+include hauxiliary in
+theorem near_omitting_le (budget : Nat) (adversary : Adversary) (omitted : FtsTree) (hbudget : budget ≤ 2 ^ 127)
+    (hcovered : ∀ monitor, CoveredRun parameter root otsSecret inputs (adversary.main ⟨root, parameter⟩)
+      ((∅, initialState PUnit.unit), monitor))
+    (hwork : ∀ result : Completed × CachedState,
+      nearLaw parameter root otsSecret labels inputs hencoding selections rows dummy slot adversary result ≠ 0 →
+        1212415 + completedWork result.1 ≤ budget) :
+    Pr[fun result => NearCertificateOmitting parameter root omitted result.1 |
+        nearLaw parameter root otsSecret labels inputs hencoding selections rows dummy slot adversary] ≤
+      (budget : ENNReal) * (((557 : ENNReal) / 14) / (2 ^ 128 : Nat)) +
+        ((budget : ENNReal) * certificateCacheExceptionRate + (2 ^ 700 : ENNReal)⁻¹) := by
+  have hcard : (Finset.univ.erase omitted).card = 13 := by
+    rw [Finset.card_erase_of_mem (Finset.mem_univ _), Finset.card_univ]
+    have h : Fintype.card FtsTree = 14 := Fintype.card_fin _
+    rw [h]
+  have h := near_omitting_total_le parameter root otsSecret labels inputs hencoding selections rows dummy slot hauxiliary budget
+    adversary omitted fixedProposalLength hbudget (hcovered _) hwork
+  rw [if_neg (show ¬ (fixedProposalLength < 25313293) from Nat.lt_irrefl _), zero_add, RetainedResidual.terminalProposalPotential_empty] at h
+  exact h.trans (add_le_add (mul_le_mul' le_rfl (uniformWordAverage_nearPrice _ hcard)) le_rfl)
+
+include hauxiliary in
+theorem nearLaw_certificate_le (budget : Nat) (adversary : Adversary) (hbudget : budget ≤ 2 ^ 127)
+    (hcovered : ∀ monitor, CoveredRun parameter root otsSecret inputs (adversary.main ⟨root, parameter⟩)
+      ((∅, initialState PUnit.unit), monitor))
+    (hwork : ∀ result : Completed × CachedState,
+      nearLaw parameter root otsSecret labels inputs hencoding selections rows dummy slot adversary result ≠ 0 →
+        1212415 + completedWork result.1 ≤ budget) :
+    Pr[fun result => completedNearCertificate parameter root result.1 |
+        nearLaw parameter root otsSecret labels inputs hencoding selections rows dummy slot adversary] ≤ nearCertificateBound budget := by
+  calc
+    _ ≤ ∑ omitted : FtsTree, Pr[fun result => NearCertificateOmitting parameter root omitted result.1 |
+        nearLaw parameter root otsSecret labels inputs hencoding selections rows dummy slot adversary] := by
+      simp_rw [probEvent_eq_tsum_ite]
+      rw [← Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)]
+      apply ENNReal.tsum_le_tsum
+      intro result
+      split_ifs with hnear
+      · obtain ⟨omitted, homitted⟩ := completedNearCertificate_exists parameter root result.1 hnear
+        refine le_trans (le_of_eq ?_) (Finset.single_le_sum (fun _ _ => zero_le) (Finset.mem_univ omitted))
+        rw [if_pos homitted]
+      · exact zero_le
+    _ ≤ ∑ _omitted : FtsTree, ((budget : ENNReal) * (((557 : ENNReal) / 14) / (2 ^ 128 : Nat)) +
+        ((budget : ENNReal) * certificateCacheExceptionRate + (2 ^ 700 : ENNReal)⁻¹)) :=
+      Finset.sum_le_sum fun omitted _ => near_omitting_le parameter root otsSecret labels inputs hencoding selections rows dummy slot
+        hauxiliary budget adversary omitted hbudget hcovered hwork
+    _ = _ := by
+      rw [Finset.sum_const, Finset.card_univ, nsmul_eq_mul]
+      have h : Fintype.card FtsTree = 14 := Fintype.card_fin _
+      rw [h, nearCertificateBound]
+      simp only [Nat.cast_ofNat]
+
+end SphincsSecurity.Concrete.FtsGuessHash
+
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec ENNReal
+open SecretGuessObservation (initialState)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+
+theorem cachedNearGame_le (dummy : OtsReferenceWords) (adversary : Adversary) (q : Nat) (hbound : HasHashQueryBound scheme adversary q)
+    (hbudget : q ≤ 2 ^ 127) (slot : Nat) :
+    Pr[fun hit => hit = true | cachedNearGame dummy adversary slot] ≤ nearCertificateBound q := by
+  unfold cachedNearGame
+  refine probEvent_bind_le_of_forall_le fun parameter _ => ?_
+  refine probEvent_bind_le_of_forall_le fun otsSecret _ => ?_
+  refine probEvent_bind_le_of_forall_le fun selections hselections => ?_
+  refine probEvent_bind_le_of_forall_le fun rows hrows => ?_
+  refine probEvent_bind_le_of_forall_le fun labels _ => ?_
+  rw [probEvent_map]
+  have hsel := pmf_mem_of_evalDist _ _ hselections
+  have hrow := pmf_mem_of_evalDist _ _ hrows
+  have hauxiliary : ∀ seed : canonicalGraphGameInputs adversary → HashOutput,
+      (⟨selections, Function.uncurry rows, seed⟩ : ReferenceAuxiliary (canonicalGraphGameInputs adversary)) ∈
+        (referenceAuxiliarySample (canonicalGraphGameInputs adversary)).support :=
+    fun seed => referenceAuxiliary_mem_support _ selections hsel rows hrow seed
+  have hcovered : ∀ monitor, CoveredRun parameter (canonicalGraphRoot labels) otsSecret (canonicalGraphGameInputs adversary)
+      (adversary.main ⟨canonicalGraphRoot labels, parameter⟩) ((∅, initialState PUnit.unit), monitor) :=
+    fun _ secrets _ =>
+      coveredInputs_main_subset adversary ⟨parameter, canonicalGraphRoot labels, otsSecret, FtsGuessSigning.secretTable.symm secrets⟩
+  have hwork : ∀ result : Completed × CachedState,
+      nearLaw parameter (canonicalGraphRoot labels) otsSecret labels (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary parameter) selections (Function.uncurry rows) dummy slot adversary result ≠ 0 →
+        1212415 + completedWork result.1 ≤ q := by
+    intro result hresult
+    have h := cachedForcedRun_original_budget dummy adversary q slot hbound parameter otsSecret labels
+      ⟨selections, Function.uncurry rows, fun _ => Classical.arbitrary _⟩ (hauxiliary _)
+    have hsel' : (⟨selections, Function.uncurry rows, fun _ => Classical.arbitrary _⟩ :
+      ReferenceAuxiliary (canonicalGraphGameInputs adversary)).selections = selections := rfl
+    have hrows' : (⟨selections, Function.uncurry rows, fun _ => Classical.arbitrary _⟩ :
+      ReferenceAuxiliary (canonicalGraphGameInputs adversary)).rows = Function.uncurry rows := rfl
+    rw [hsel', hrows'] at h
+    exact (h result hresult).1
+  have h := nearLaw_certificate_le parameter (canonicalGraphRoot labels) otsSecret labels (canonicalGraphGameInputs adversary)
+    (canonicalEncodingInputs_subset_gameInputs adversary parameter) selections (Function.uncurry rows) dummy slot hauxiliary q adversary
+    hbudget hcovered hwork
+  simpa only [Function.comp_def, decide_eq_true_eq] using h
+
+theorem forcedNearGame_le (dummy : OtsReferenceWords) (adversary : Adversary) (q : Nat) (hbound : HasHashQueryBound scheme adversary q)
+    (hbudget : q ≤ 2 ^ 127) (slot : Nat) :
+    Pr[fun hit => hit = true | forcedNearGame dummy adversary slot] ≤ nearCertificateBound q := by
+  rw [forcedNearGame_cached]
+  exact cachedNearGame_le dummy adversary q hbound hbudget slot
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessNearDeferred.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessNearDeferred.lean
new file mode 100644
index 000000000..814c988e6
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessNearDeferred.lean
@@ -0,0 +1,76 @@
+import SphincsSecurity.Proof.Forced.FtsGuessDeferredSeed
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec UniformTableCompletion
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  publicDigestLoop canonicalGraphRoot canonicalGraphInput
+
+noncomputable def forcedNearDeferredGame (dummy : OtsReferenceWords) (adversary : Adversary) (slot : Nat) : SPMF Bool := do
+  let parameter ← 𝒟[sampleParameter]
+  let otsSecret ← 𝒟[sampleOtsSecrets]
+  let selections ← 𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit]
+  let rows ← 𝒟[FirstSuccessFamily.afterSelect decodeEncodingOutput encodingAttemptLimit decodeEncodingOutput_invalid_nonempty selections]
+  let labels ← 𝒟[PMF.uniformOfFintype CanonicalGraphLabels]
+  (fun result => decide (completedNearCertificate parameter (canonicalGraphRoot labels) result.1.1)) <$>
+    deferredForcedRun parameter (canonicalGraphRoot labels) otsSecret labels (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary parameter) selections (Function.uncurry rows) dummy slot adversary
+
+theorem forcedNearGame_deferred (dummy : OtsReferenceWords) (adversary : Adversary) (slot : Nat) :
+    forcedNearGame dummy adversary slot = forcedNearDeferredGame dummy adversary slot := by
+  simp only [forcedNearGame, forcedNearDeferredGame, referenceAuxiliarySample, ← PMF.monad_bind_eq_bind,
+    ← PMF.monad_map_eq_map, evalDist_bind, evalDist_map, bind_assoc, bind_map_left]
+  apply congrArg (𝒟[sampleParameter] >>= ·)
+  funext parameter
+  apply congrArg (𝒟[sampleOtsSecrets] >>= ·)
+  funext otsSecret
+  apply congrArg (𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit] >>= ·)
+  funext selections
+  apply congrArg (𝒟[FirstSuccessFamily.afterSelect decodeEncodingOutput encodingAttemptLimit
+    decodeEncodingOutput_invalid_nonempty selections] >>= ·)
+  funext rows
+  rw [RetainedObservation.bind_comm]
+  apply congrArg (𝒟[PMF.uniformOfFintype CanonicalGraphLabels] >>= ·)
+  funext labels
+  have h := congrArg (Functor.map (fun result => decide (completedNearCertificate parameter (canonicalGraphRoot labels) result.1)))
+    (forcedRun_seed_marginal parameter (canonicalGraphRoot labels) otsSecret labels (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary parameter) selections (Function.uncurry rows) dummy slot adversary)
+  simpa only [map_bind, Functor.map_map, originalAnswers] using h
+
+theorem referenceAuxiliary_seed_support (inputs : Finset HashInput) (auxiliary : ReferenceAuxiliary inputs)
+    (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support) (seed : inputs → HashOutput) :
+    { auxiliary with seed := seed } ∈ (referenceAuxiliarySample inputs).support := by
+  rw [referenceAuxiliarySample, PMF.mem_support_bind_iff] at hauxiliary ⊢
+  obtain ⟨selections, hselections, hauxiliary⟩ := hauxiliary
+  rw [PMF.mem_support_bind_iff] at hauxiliary
+  obtain ⟨rows, hrows, hauxiliary⟩ := hauxiliary
+  rw [PMF.mem_support_map_iff] at hauxiliary
+  obtain ⟨oldSeed, _, rfl⟩ := hauxiliary
+  refine ⟨selections, hselections, ?_⟩
+  rw [PMF.mem_support_bind_iff]
+  refine ⟨rows, hrows, ?_⟩
+  rw [PMF.mem_support_map_iff]
+  exact ⟨seed, PMF.mem_support_uniformOfFintype seed, rfl⟩
+
+theorem deferredForcedRun_original_budget (dummy : OtsReferenceWords) (adversary : Adversary) (q slot : Nat)
+    (hbound : HasHashQueryBound scheme adversary q) (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary (canonicalGraphGameInputs adversary))
+    (hauxiliary : auxiliary ∈ (referenceAuxiliarySample (canonicalGraphGameInputs adversary)).support)
+    (result : (Completed × SecretGuessObservation.State FtsGuessSigning.Coordinate Digest PUnit) ×
+      (canonicalGraphGameInputs adversary → Finset HashOutput))
+    (hr : deferredForcedRun parameter (canonicalGraphRoot labels) otsSecret labels (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary parameter) auxiliary.selections auxiliary.rows dummy slot adversary result ≠ 0) :
+    1212415 + completedWork result.1.1 ≤ q ∧ result.1.2.probes ≤ completedWork result.1.1 := by
+  have hp : (Prod.fst <$> deferredForcedRun parameter (canonicalGraphRoot labels) otsSecret labels
+      (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary parameter)
+      auxiliary.selections auxiliary.rows dummy slot adversary) result.1 ≠ 0 := by
+    rw [map_eq_bind_pure_comp, RetainedObservation.bind_nonzero]
+    exact ⟨result, hr, by simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not]⟩
+  rw [← forcedRun_seed_marginal, RetainedObservation.bind_nonzero] at hp
+  obtain ⟨seed, _, hs⟩ := hp
+  exact forced_original_completedRun_budget dummy adversary q slot hbound parameter otsSecret labels
+    { auxiliary with seed := seed } (referenceAuxiliary_seed_support _ auxiliary hauxiliary seed) result.1 hs
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessNearEvent.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessNearEvent.lean
new file mode 100644
index 000000000..fa56eb973
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessNearEvent.lean
@@ -0,0 +1,69 @@
+import SphincsSecurity.Proof.Forced.FtsGuessNearWitness
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec ENNReal UniformTableCompletion
+open FtsGuessSigning (Coordinate)
+open SecretGuessObservation (State lazyRun forcedRun initialState)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  frontierRoot maskOtsPrefixes frontierSigningRun boundaryEval
+
+noncomputable def forcedNearProbability (dummy : OtsReferenceWords) (adversary : Adversary) (slot : Nat)
+    (parameter : PublicParameter) (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (labels : CanonicalGraphLabels) (auxiliary : ReferenceAuxiliary (canonicalGraphGameInputs adversary)) : ENNReal :=
+  Pr[fun result => completedNearCertificate parameter (canonicalGraphRoot labels) result.1 |
+    forcedRun (SecretGuessObservation.environment (originalAnswers dummy adversary parameter otsSecret labels auxiliary)) slot
+      (completedRun parameter (canonicalGraphRoot labels) labels adversary) (initialState PUnit.unit)]
+
+theorem lazy_original_near_event_le (dummy : OtsReferenceWords) (adversary : Adversary) (budget : Nat)
+    (hbudget : HasHashQueryBound scheme adversary budget) (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary (canonicalGraphGameInputs adversary))
+    (hauxiliary : auxiliary ∈ (referenceAuxiliarySample (canonicalGraphGameInputs adversary)).support) :
+    Pr[fun result => result.2.guesses.Nonempty ∧ completedNearCertificate parameter (canonicalGraphRoot labels) result.1 |
+      lazyRun (SecretGuessObservation.environment (originalAnswers dummy adversary parameter otsSecret labels auxiliary))
+        (completedRun parameter (canonicalGraphRoot labels) labels adversary) (initialState PUnit.unit)] ≤
+      ((2 ^ 128 - budget : Nat) : ENNReal)⁻¹ *
+        ∑ slot ∈ Finset.range budget, forcedNearProbability dummy adversary slot parameter otsSecret labels auxiliary := by
+  have h := SecretGuessObservation.lazyRun_event_le_forced
+    (SecretGuessObservation.environment (originalAnswers dummy adversary parameter otsSecret labels auxiliary))
+    (completedRun parameter (canonicalGraphRoot labels) labels adversary) PUnit.unit budget
+    (fun result hr => (Nat.le_add_left _ _).trans
+      (lazy_original_completedRun_probes dummy adversary budget hbudget parameter otsSecret labels auxiliary hauxiliary result hr))
+    (fun result => result.2.guesses.Nonempty ∧ completedNearCertificate parameter (canonicalGraphRoot labels) result.1)
+    (fun result => if completedNearCertificate parameter (canonicalGraphRoot labels) result.1 then 1 else 0)
+    (fun _ _ he => ⟨he.1, by rw [if_pos he.2]⟩)
+  simpa only [forcedNearProbability, probEvent_eq_tsum_ite, mul_ite, mul_one, mul_zero,
+    show Fintype.card Digest = 2 ^ 128 by simp [digestBits]] using h
+
+theorem initial_reference_near_witnesses (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary inputs) (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    Pr[fun result => completedNearGuess ⟨parameter, canonicalGraphRoot labels, otsSecret, FtsGuessSigning.secretTable.symm result.1⟩
+      (programmedHash parameter otsSecret (FtsGuessSigning.secretTable.symm result.1) labels
+        (finiteHashAnswer ∅ inputs (canonicalReferenceResidual parameter inputs hencoding labels auxiliary.rows auxiliary.seed))) result.2 |
+      complete (fun _ : Coordinate => (Finset.univ : Finset Digest)) >>= fun secrets =>
+        (fun value => (secrets, value)) <$> 𝒟[simulateQ
+          (fixedAnswers (referenceAnswers parameter (canonicalGraphRoot labels) otsSecret labels inputs hencoding auxiliary dummy) secrets)
+          (completedRun parameter (canonicalGraphRoot labels) labels adversary)]] ≤
+      Pr[fun result => result.2.guesses.Nonempty ∧ completedNearCertificate parameter (canonicalGraphRoot labels) result.1 |
+        lazyRun (SecretGuessObservation.environment
+          (referenceAnswers parameter (canonicalGraphRoot labels) otsSecret labels inputs hencoding auxiliary dummy))
+          (completedRun parameter (canonicalGraphRoot labels) labels adversary) (initialState PUnit.unit)] := by
+  apply initialEvent_le _ _ (fun secrets result => completedNearGuess
+    ⟨parameter, canonicalGraphRoot labels, otsSecret, FtsGuessSigning.secretTable.symm secrets⟩
+    (programmedHash parameter otsSecret (FtsGuessSigning.secretTable.symm secrets) labels
+      (finiteHashAnswer ∅ inputs (canonicalReferenceResidual parameter inputs hencoding labels auxiliary.rows auxiliary.seed))) result)
+    (fun result => result.2.guesses.Nonempty ∧ completedNearCertificate parameter (canonicalGraphRoot labels) result.1)
+  intro result hr secrets hs hevent
+  refine lazy_reference_near_witnesses ⟨parameter, canonicalGraphRoot labels, otsSecret, FtsGuessSigning.secretTable.symm secrets⟩
+    inputs hencoding labels auxiliary hauxiliary dummy adversary result hr ?_ hevent
+  have htable : FtsGuessSigning.secretTable
+      (⟨parameter, canonicalGraphRoot labels, otsSecret, FtsGuessSigning.secretTable.symm secrets⟩ : SecretKey).ftsSecret = secrets :=
+    Equiv.apply_symm_apply FtsGuessSigning.secretTable secrets
+  exact (congrArg (fun table => complete result.2.allowed table ≠ 0) htable).mpr hs
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessNearSource.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessNearSource.lean
new file mode 100644
index 000000000..3f386a790
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessNearSource.lean
@@ -0,0 +1,164 @@
+import SphincsSecurity.Proof.Forced.FtsGuessNearEvent
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec OtsContactTrace ENNReal UniformTableCompletion
+open FtsGuessSigning (Coordinate)
+open SecretGuessObservation (forcedRun initialState)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  frontierRoot maskOtsPrefixes frontierSigningRun boundaryEval honestNode canonicalGraphLabels
+
+noncomputable def sourceNearWitness (key : SecretKey) (f : QueryImpl HashSpec Id) (labels : CanonicalGraphLabels)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords) (before : AdversaryTrace) : Prop :=
+  let result := completedReferenceContact key.parameter f (referenceFamilyWords selections dummy)
+    (canonicalGraphFrontier key.otsSecret labels (referenceFamilyWords selections dummy)) before
+  SigningTranscript.Valid before.1.1.2 ∧ ReferenceFtsCoverage.NearGuess (ReferenceVerifierWitness.rootedKey key f) f
+    before.1.1.2 before.1.2 (result.before * result.after) before.1.1.1
+
+noncomputable def referenceNearWitnessRest (key : SecretKey) (f : QueryImpl HashSpec Id) (labels : CanonicalGraphLabels)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords) (adversary : Adversary) : ProbComp Bool :=
+  (fun before => decide (sourceNearWitness key f labels selections dummy before)) <$>
+    referenceForgeryRest key f labels selections dummy adversary
+
+theorem referenceNearWitnessRest_program (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary inputs) (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    let f := programmedHash key.parameter key.otsSecret key.ftsSecret labels
+      (finiteHashAnswer ∅ inputs (canonicalReferenceResidual key.parameter inputs hencoding labels auxiliary.rows auxiliary.seed))
+    referenceNearWitnessRest key f labels auxiliary.selections dummy adversary =
+      (fun result => decide (completedNearGuess { key with root := canonicalGraphRoot labels } f result)) <$>
+        simulateQ (fixedAnswers (referenceAnswers key.parameter (canonicalGraphRoot labels) key.otsSecret labels inputs hencoding auxiliary dummy)
+          (FtsGuessSigning.secretTable key.ftsSecret)) (completedRun key.parameter (canonicalGraphRoot labels) labels adversary) := by
+  dsimp only
+  rw [fixed_reference_completedForgeryRest key inputs hencoding labels auxiliary hauxiliary dummy adversary,
+    referenceNearWitnessRest, Functor.map_map]
+  congr 1
+  funext before
+  rw [sourceNearWitness, rootedKey_programmedHash key labels _ dummy]
+  simp only [completedReferenceContact, reference_root, completedNearGuess, completedAtRoot]
+  exact decide_eq_decide.mpr Iff.rfl
+
+theorem referenceNearWitnessRest_initial_bound (dummy : OtsReferenceWords) (adversary : Adversary) (budget : Nat)
+    (hbudget : HasHashQueryBound scheme adversary budget) (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary (canonicalGraphGameInputs adversary))
+    (hauxiliary : auxiliary ∈ (referenceAuxiliarySample (canonicalGraphGameInputs adversary)).support) :
+    Pr[fun hit => hit = true | 𝒟[sampleFtsSecrets] >>= fun ftsSecret =>
+      𝒟[referenceNearWitnessRest ⟨parameter, 0, otsSecret, ftsSecret⟩
+        (programmedHash parameter otsSecret ftsSecret labels
+          (finiteHashAnswer ∅ (canonicalGraphGameInputs adversary)
+            (canonicalReferenceResidual parameter (canonicalGraphGameInputs adversary)
+              (canonicalEncodingInputs_subset_gameInputs adversary parameter) labels auxiliary.rows auxiliary.seed)))
+        labels auxiliary.selections dummy adversary]] ≤
+      ((2 ^ 128 - budget : Nat) : ENNReal)⁻¹ *
+        ∑ slot ∈ Finset.range budget, forcedNearProbability dummy adversary slot parameter otsSecret labels auxiliary := by
+  have h := (initial_reference_near_witnesses parameter otsSecret (canonicalGraphGameInputs adversary)
+    (canonicalEncodingInputs_subset_gameInputs adversary parameter) labels auxiliary hauxiliary dummy adversary).trans
+    (lazy_original_near_event_le dummy adversary budget hbudget parameter otsSecret labels auxiliary hauxiliary)
+  have hprior := congrArg (fun law : SPMF (Coordinate → Digest) => law >>= fun secrets =>
+      (fun result => (secrets, result)) <$> 𝒟[simulateQ
+        (fixedAnswers (originalAnswers dummy adversary parameter otsSecret labels auxiliary) secrets)
+        (completedRun parameter (canonicalGraphRoot labels) labels adversary)]) FtsGuessSigning.sampleFtsSecrets_table
+  rw [bind_map_left] at hprior
+  simp only [originalAnswers] at hprior
+  rw [← hprior] at h
+  have hprogram (ftsSecret : Index → FtsTree → FtsLeaf → Digest) := referenceNearWitnessRest_program
+    ⟨parameter, 0, otsSecret, ftsSecret⟩ (canonicalGraphGameInputs adversary)
+    (canonicalEncodingInputs_subset_gameInputs adversary parameter) labels auxiliary hauxiliary dummy adversary
+  simp only [hprogram, evalDist_map, probEvent_bind_eq_tsum, probEvent_map, Function.comp_def,
+    Equiv.symm_apply_apply, decide_eq_true_eq] at h ⊢
+  exact h
+
+noncomputable def forcedNearGame (dummy : OtsReferenceWords) (adversary : Adversary) (slot : Nat) : SPMF Bool := do
+  let parameter ← 𝒟[sampleParameter]
+  let otsSecret ← 𝒟[sampleOtsSecrets]
+  let auxiliary ← 𝒟[referenceAuxiliarySample (canonicalGraphGameInputs adversary)]
+  let labels ← 𝒟[PMF.uniformOfFintype CanonicalGraphLabels]
+  (fun result => decide (completedNearCertificate parameter (canonicalGraphRoot labels) result.1)) <$>
+    forcedRun (SecretGuessObservation.environment (originalAnswers dummy adversary parameter otsSecret labels auxiliary)) slot
+      (completedRun parameter (canonicalGraphRoot labels) labels adversary) (initialState PUnit.unit)
+
+theorem forcedNearGame_probability (dummy : OtsReferenceWords) (adversary : Adversary) (slot : Nat) :
+    Pr[fun hit => hit = true | forcedNearGame dummy adversary slot] =
+      ∑' parameter, Pr[= parameter | 𝒟[sampleParameter]] *
+        ∑' otsSecret, Pr[= otsSecret | 𝒟[sampleOtsSecrets]] *
+          ∑' auxiliary, Pr[= auxiliary | 𝒟[referenceAuxiliarySample (canonicalGraphGameInputs adversary)]] *
+            ∑' labels, Pr[= labels | 𝒟[PMF.uniformOfFintype CanonicalGraphLabels]] *
+              forcedNearProbability dummy adversary slot parameter otsSecret labels auxiliary := by
+  simp only [forcedNearGame, probEvent_bind_eq_tsum, probEvent_map, Function.comp_def, decide_eq_true_eq, forcedNearProbability]
+
+private theorem weighted_sum {Index First : Type} (indices : Finset Index) (law : SPMF First)
+    (value : Index → First → ENNReal) (rate : ENNReal) :
+    rate * (∑ index ∈ indices, ∑' first, Pr[= first | law] * value index first) =
+      ∑' first, Pr[= first | law] * (rate * ∑ index ∈ indices, value index first) := by
+  rw [← Summable.tsum_finsetSum (fun _ _ => ENNReal.summable), ← ENNReal.tsum_mul_left]
+  apply tsum_congr
+  intro first
+  rw [← Finset.mul_sum]
+  ring
+
+private theorem pmf_support_nonzero {Result : Type} (law : PMF Result) (result : Result) (hr : 𝒟[law] result ≠ 0) :
+    result ∈ law.support := by
+  simpa only [PMF.mem_support_iff, SPMF.liftM_apply] using hr
+
+theorem referenceForgeryGame_near_guess_le_forced (dummy : OtsReferenceWords) (adversary : Adversary) (budget : Nat)
+    (hbudget : HasHashQueryBound scheme adversary budget) :
+    Pr[ReferenceForgerySample.nearGuess dummy | referenceForgeryGame (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] ≤
+      ((2 ^ 128 - budget : Nat) : ENNReal)⁻¹ *
+        ∑ slot ∈ Finset.range budget, Pr[fun hit => hit = true | forcedNearGame dummy adversary slot] := by
+  have hsource := referenceForgeryGame_bind_auxiliary (canonicalGraphGameInputs adversary)
+    (canonicalEncodingInputs_subset_gameInputs adversary) (canonicalGraphInputs_subset_gameInputs adversary) dummy adversary
+    (fun key f labels selections before => pure (decide (sourceNearWitness key f labels selections dummy before)))
+  simp only [evalDist_pure, bind_pure_comp] at hsource
+  have hprojected := congrArg (fun law : SPMF Bool => Pr[fun hit => hit = true | law]) hsource
+  simp only [probEvent_map, Function.comp_def, decide_eq_true_eq] at hprojected
+  change Pr[ReferenceForgerySample.nearGuess dummy | referenceForgeryGame (canonicalGraphGameInputs adversary)
+    (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] = _ at hprojected
+  rw [hprojected]
+  simp_rw [forcedNearGame_probability, weighted_sum]
+  rw [probEvent_bind_eq_tsum]
+  apply ENNReal.tsum_le_tsum
+  intro parameter
+  apply mul_le_mul' le_rfl
+  rw [probEvent_bind_eq_tsum]
+  apply ENNReal.tsum_le_tsum
+  intro otsSecret
+  apply mul_le_mul' le_rfl
+  rw [RetainedObservation.bind_comm 𝒟[sampleFtsSecrets] 𝒟[referenceAuxiliarySample (canonicalGraphGameInputs adversary)],
+    probEvent_bind_eq_tsum]
+  apply ENNReal.tsum_le_tsum
+  intro auxiliary
+  by_cases hz : 𝒟[referenceAuxiliarySample (canonicalGraphGameInputs adversary)] auxiliary = 0
+  · simp only [SPMF.probOutput_eq_apply, hz, zero_mul, le_refl]
+  apply mul_le_mul' le_rfl
+  rw [RetainedObservation.bind_comm 𝒟[sampleFtsSecrets] 𝒟[PMF.uniformOfFintype CanonicalGraphLabels],
+    probEvent_bind_eq_tsum]
+  apply ENNReal.tsum_le_tsum
+  intro labels
+  apply mul_le_mul' le_rfl
+  have h := referenceNearWitnessRest_initial_bound dummy adversary budget hbudget parameter otsSecret labels auxiliary
+    (pmf_support_nonzero _ auxiliary hz)
+  simpa only [referenceNearWitnessRest, evalDist_map] using h
+
+end SphincsSecurity.Concrete.FtsGuessHash
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp ENNReal
+
+theorem forgeAdvantage_le_forcedNear_small_budget (dummy : OtsReferenceWords)
+    (hdummy : ∀ lay tree leaf, TargetSum.Valid (dummy lay tree leaf))
+    (adversary : Adversary) (q : Nat) (hbound : HasHashQueryBound scheme adversary q)
+    (hsmall : q ≤ 3 * 2 ^ 114) :
+    forgeAdvantage scheme adversary ≤
+      (7 / 4 : ENNReal) * ((q : ENNReal) / 2 ^ 128) + (q : ENNReal) * (11 / 2 ^ 144 : ENNReal) +
+      (2 ^ 700 : ENNReal)⁻¹ + ((q : ENNReal) / 2 ^ 128) ^ 2 / (2 * (1 - (q : ENNReal) / 2 ^ 128) ^ 2) +
+      ((2 ^ 128 - q : Nat) : ENNReal)⁻¹ *
+        ∑ slot ∈ Finset.range q, Pr[fun hit => hit = true | FtsGuessHash.forcedNearGame dummy adversary slot] :=
+  (forgeAdvantage_le_nearGuess_normalized_small_budget dummy hdummy adversary q hbound hsmall).trans
+    (add_le_add le_rfl (FtsGuessHash.referenceForgeryGame_near_guess_le_forced dummy adversary q hbound))
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessNearWitness.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessNearWitness.lean
new file mode 100644
index 000000000..3562081c8
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessNearWitness.lean
@@ -0,0 +1,125 @@
+import SphincsSecurity.Proof.Forced.FtsGuessRemaining
+import SphincsSecurity.Proof.Forced.SecretGuessHitPayoff
+
+/-! ## FtsGuessForcedBudget -/
+
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsGuessSigning (Coordinate)
+open SecretGuessObservation (State forcedRun initialState)
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  frontierRoot maskOtsPrefixes frontierSigningRun boundaryEval
+
+theorem forced_original_completedRun_budget (dummy : OtsReferenceWords) (adversary : Adversary) (q slot : Nat)
+    (hbound : HasHashQueryBound scheme adversary q) (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary (canonicalGraphGameInputs adversary))
+    (hauxiliary : auxiliary ∈ (referenceAuxiliarySample (canonicalGraphGameInputs adversary)).support)
+    (result : Completed × State Coordinate Digest PUnit)
+    (hr : forcedRun (SecretGuessObservation.environment (originalAnswers dummy adversary parameter otsSecret labels auxiliary)) slot
+      (completedRun parameter (canonicalGraphRoot labels) labels adversary) (initialState PUnit.unit) result ≠ 0) :
+    1212415 + completedWork result.1 ≤ q ∧ result.2.probes ≤ completedWork result.1 :=
+  lazy_original_completedRun_budget dummy adversary q hbound parameter otsSecret labels auxiliary hauxiliary result
+    (SecretGuessObservation.forcedRun_nonzero _ slot _ _ result hr)
+
+end SphincsSecurity.Concrete.FtsGuessHash
+
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec OtsContactTrace UniformTableCompletion
+open FtsGuessSigning (Coordinate)
+open SecretGuessObservation (State fixedRun lazyRun initialState)
+open RetainedResidual (signingInput)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  frontierRoot maskOtsPrefixes frontierSigningRun boundaryEval honestNode canonicalGraphLabels
+
+def completedNearGuess (key : SecretKey) (f : QueryImpl HashSpec Id) (result : Completed) : Prop :=
+  SigningTranscript.Valid result.1.1.1.2 ∧ ReferenceFtsCoverage.NearGuess key f result.1.1.1.2 result.1.1.2
+    (result.1.2 * result.2.2) result.1.1.1.1
+
+noncomputable def completedNearCertificate (parameter : PublicParameter) (root : Digest) (result : Completed) : Prop :=
+  let key : SecretKey := ⟨parameter, root, fun _ _ _ _ => 0, fun _ _ _ => 0⟩
+  SigningTranscript.Valid result.1.1.1.2 ∧ ∃ omitted : FtsTree,
+    TargetCertificateAt key (Finset.univ.erase omitted)
+      (hashRowsCache (result.1.1.2 * result.2.1.2).messageCalls, result.1.1.1.2)
+      (signingInput key result.1.1.1.1.message result.1.1.1.1.signature)
+
+theorem completedNearCertificate_iff (key : SecretKey) (result : Completed) :
+    completedNearCertificate key.parameter key.root result ↔
+      SigningTranscript.Valid result.1.1.1.2 ∧ ∃ omitted : FtsTree,
+        TargetCertificateAt key (Finset.univ.erase omitted)
+          (hashRowsCache (result.1.1.2 * result.2.1.2).messageCalls, result.1.1.1.2)
+          (signingInput key result.1.1.1.1.message result.1.1.1.1.signature) := Iff.rfl
+
+theorem reference_completed_nearCertificate (key : SecretKey) (f : QueryImpl HashSpec Id) (root : Digest)
+    (hroot : root = (ReferenceVerifierWitness.rootedKey key f).root)
+    (dummy : OtsReferenceWords) (adversary : Adversary) (before : AdversaryTrace)
+    (hb : before ∈ support (referenceForgeryRest key f (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f)
+      (referenceTableSelection key f) dummy adversary))
+    (hevent : completedNearGuess { key with root := root } f (completedAtRoot key.parameter root f before)) :
+    completedNearCertificate key.parameter root (completedAtRoot key.parameter root f before) := by
+  rw [completedNearCertificate_iff { key with root := root }]
+  obtain ⟨hvalid, omitted, hcertificate, _⟩ := hevent
+  refine ⟨hvalid, omitted, ?_⟩
+  have h := referenceForgeryRest_certificate_atRoot key f root hroot dummy adversary before hb _ _ hcertificate
+  simpa only [completeCertificateRest, completedAtRoot] using h
+
+private theorem map_nonzero {First Result : Type} (function : First → Result) (law : SPMF First) (result : Result) :
+    (function <$> law) result ≠ 0 ↔ ∃ first, law first ≠ 0 ∧ result = function first := by
+  simp only [map_eq_bind_pure_comp, RetainedObservation.bind_nonzero, Function.comp_def,
+    ne_eq, SPMF.pure_apply_eq_zero_iff, not_not]
+
+private theorem supported_probComp {Result : Type} (law : ProbComp Result) (result : Result) (hr : 𝒟[law] result ≠ 0) :
+    result ∈ support law := by
+  simpa only [mem_support_iff, probOutput_def] using hr
+
+theorem fixed_reference_completed_nearCertificate (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary inputs) (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support)
+    (dummy : OtsReferenceWords) (adversary : Adversary) (result : Completed)
+    (hr : 𝒟[simulateQ
+      (fixedAnswers (referenceAnswers key.parameter (canonicalGraphRoot labels) key.otsSecret labels inputs hencoding auxiliary dummy)
+        (FtsGuessSigning.secretTable key.ftsSecret)) (completedRun key.parameter (canonicalGraphRoot labels) labels adversary)] result ≠ 0)
+    (hevent : completedNearGuess { key with root := canonicalGraphRoot labels }
+      (programmedHash key.parameter key.otsSecret key.ftsSecret labels
+        (finiteHashAnswer ∅ inputs (canonicalReferenceResidual key.parameter inputs hencoding labels auxiliary.rows auxiliary.seed))) result) :
+    completedNearCertificate key.parameter (canonicalGraphRoot labels) result := by
+  rw [fixed_reference_completedForgeryRest key inputs hencoding labels auxiliary hauxiliary dummy adversary, evalDist_map,
+    map_nonzero] at hr
+  obtain ⟨before, hb, rfl⟩ := hr
+  apply reference_completed_nearCertificate key _ (canonicalGraphRoot labels) _ dummy adversary before _ hevent
+  · exact (congrArg SecretKey.root (rootedKey_programmedHash key labels _ dummy)).symm
+  · rw [canonicalGraphLabels_programmedHash, referenceTableSelection_auxiliary key inputs hencoding labels auxiliary hauxiliary]
+    exact supported_probComp _ before hb
+
+theorem lazy_reference_near_witnesses (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary inputs) (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support)
+    (dummy : OtsReferenceWords) (adversary : Adversary) (result : Completed × State Coordinate Digest PUnit)
+    (hr : lazyRun
+      (SecretGuessObservation.environment
+        (referenceAnswers key.parameter (canonicalGraphRoot labels) key.otsSecret labels inputs hencoding auxiliary dummy))
+      (completedRun key.parameter (canonicalGraphRoot labels) labels adversary) (initialState PUnit.unit) result ≠ 0)
+    (hsecrets : complete result.2.allowed (FtsGuessSigning.secretTable key.ftsSecret) ≠ 0)
+    (hevent : completedNearGuess { key with root := canonicalGraphRoot labels }
+      (programmedHash key.parameter key.otsSecret key.ftsSecret labels
+        (finiteHashAnswer ∅ inputs (canonicalReferenceResidual key.parameter inputs hencoding labels auxiliary.rows auxiliary.seed))) result.1) :
+    result.2.guesses.Nonempty ∧ completedNearCertificate key.parameter (canonicalGraphRoot labels) result.1 := by
+  have hfixed := fixedRun_nonzero_of_lazy_posterior _ _ (initialState PUnit.unit) result _ hr hsecrets
+  have hprojected := (map_nonzero Prod.fst _ result.1).mpr ⟨result, hfixed, rfl⟩
+  rw [SecretGuessObservation.fixedRun_projection] at hprojected
+  have htable : FtsGuessSigning.secretTable ({ key with root := canonicalGraphRoot labels } : SecretKey).ftsSecret =
+      FtsGuessSigning.secretTable key.ftsSecret := rfl
+  have tracking := lazy_reference_completedRun_tracking { key with root := canonicalGraphRoot labels }
+    inputs hencoding labels auxiliary hauxiliary dummy adversary (initialState PUnit.unit) result hr
+    ((congrArg (fun table => complete result.2.allowed table ≠ 0) htable).mpr hsecrets)
+  have hnear := tracking.near_guess rfl _ _ hevent.2
+  obtain ⟨omitted, _, hguess⟩ := hnear
+  exact ⟨⟨_, hguess⟩, fixed_reference_completed_nearCertificate key inputs hencoding labels auxiliary hauxiliary
+    dummy adversary result.1 hprojected hevent⟩
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessPairBound.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessPairBound.lean
new file mode 100644
index 000000000..07a24071b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessPairBound.lean
@@ -0,0 +1,60 @@
+import SphincsSecurity.Proof.Forced.SecretGuessPairBound
+import SphincsSecurity.Proof.Forced.FtsGuessBudget
+import SphincsSecurity.Proof.Forced.FtsGuessReferenceWitness
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsGuessSigning (Coordinate)
+open SecretGuessObservation (State lazyRun initialState)
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  frontierRoot maskOtsPrefixes frontierSigningRun boundaryEval
+
+noncomputable def pairRate (budget : Nat) : ENNReal :=
+  (budget.choose 2 : ENNReal) * ((2 ^ 128 - budget : Nat) : ENNReal)⁻¹ ^ 2
+
+theorem pairRate_le_quadratic (budget : Nat) :
+    pairRate budget ≤ (budget : ENNReal) ^ 2 / (2 * ((2 ^ 128 - budget : Nat) : ENNReal) ^ 2) := by
+  have hchoose : budget.choose 2 * 2 ≤ budget * budget := by
+    rw [Nat.choose_two_right]
+    exact (Nat.div_mul_le_self _ _).trans (Nat.mul_le_mul_left _ (Nat.sub_le _ _))
+  have hcast : (budget.choose 2 : ENNReal) ≤ (budget : ENNReal) ^ 2 / 2 := by
+    apply (ENNReal.le_div_iff_mul_le (Or.inl (by norm_num)) (Or.inl (by norm_num))).mpr
+    simpa only [pow_two, Nat.cast_mul, Nat.cast_ofNat] using (show ((budget.choose 2 * 2 : Nat) : ENNReal) ≤
+      ((budget * budget : Nat) : ENNReal) by exact_mod_cast hchoose)
+  calc
+    _ ≤ (budget : ENNReal) ^ 2 / 2 * ((2 ^ 128 - budget : Nat) : ENNReal)⁻¹ ^ 2 := mul_le_mul' hcast le_rfl
+    _ = _ := by
+      rw [div_eq_mul_inv, div_eq_mul_inv,
+        ENNReal.mul_inv (Or.inl (by norm_num : (2 : ENNReal) ≠ 0)) (Or.inl (by norm_num : (2 : ENNReal) ≠ ⊤)),
+        ENNReal.inv_pow, mul_assoc]
+
+theorem pairRate_le_normalized (budget : Nat) :
+    pairRate budget ≤ ((budget : ENNReal) / 2 ^ 128) ^ 2 / (2 * (1 - (budget : ENNReal) / 2 ^ 128) ^ 2) := by
+  have hsub : 1 - (budget : ENNReal) / 2 ^ 128 = ((2 ^ 128 - budget : Nat) : ENNReal) / 2 ^ 128 := by
+    rw [ENNReal.natCast_sub, Nat.cast_pow, Nat.cast_ofNat,
+      ENNReal.sub_div (fun _ _ => by positivity), ENNReal.div_self (by positivity) (by finiteness)]
+  have hpow (value : ENNReal) : (value / 2 ^ 128) ^ 2 = value ^ 2 * ((2 ^ 128 : ENNReal)⁻¹) ^ 2 := by
+    rw [div_eq_mul_inv, mul_pow]
+  calc
+    _ ≤ (budget : ENNReal) ^ 2 / (2 * ((2 ^ 128 - budget : Nat) : ENNReal) ^ 2) := pairRate_le_quadratic budget
+    _ = _ := by
+      rw [hsub, hpow, hpow, ← mul_assoc]
+      exact (ENNReal.mul_div_mul_right _ _ (pow_ne_zero _ (by simp)) (by finiteness)).symm
+
+theorem lazy_original_two_guesses (dummy : OtsReferenceWords) (adversary : Adversary) (budget : Nat)
+    (hbudget : HasHashQueryBound scheme adversary budget) (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary (canonicalGraphGameInputs adversary))
+    (hauxiliary : auxiliary ∈ (referenceAuxiliarySample (canonicalGraphGameInputs adversary)).support) :
+    Pr[fun result => 2 ≤ result.2.guesses.card | lazyRun
+      (SecretGuessObservation.environment (originalAnswers dummy adversary parameter otsSecret labels auxiliary))
+      (completedRun parameter (canonicalGraphRoot labels) labels adversary) (initialState PUnit.unit)] ≤ pairRate budget := by
+  have hbound := SecretGuessObservation.lazyRun_two_guesses
+    (SecretGuessObservation.environment (originalAnswers dummy adversary parameter otsSecret labels auxiliary))
+    (completedRun parameter (canonicalGraphRoot labels) labels adversary) PUnit.unit budget
+    (fun result hr => (Nat.le_add_left _ _).trans
+      (lazy_original_completedRun_probes dummy adversary budget hbudget parameter otsSecret labels auxiliary hauxiliary result hr))
+  simpa only [pairRate, show Fintype.card Digest = 2 ^ 128 by simp [digestBits]] using hbound
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessPairSource.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessPairSource.lean
new file mode 100644
index 000000000..2028dae7a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessPairSource.lean
@@ -0,0 +1,117 @@
+import SphincsSecurity.Proof.Forced.FtsGuessEventTransfer
+import SphincsSecurity.Proof.Reference.ReferenceForgeryAuxiliary
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec OtsContactTrace UniformTableCompletion
+open FtsGuessSigning (Coordinate)
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  frontierRoot maskOtsPrefixes frontierSigningRun boundaryEval honestNode canonicalGraphLabels
+
+noncomputable def sourceTwoWitnesses (key : SecretKey) (f : QueryImpl HashSpec Id) (labels : CanonicalGraphLabels)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords) (before : AdversaryTrace) : Prop :=
+  let result := completedReferenceContact key.parameter f (referenceFamilyWords selections dummy)
+    (canonicalGraphFrontier key.otsSecret labels (referenceFamilyWords selections dummy)) before
+  ReferenceFtsCoverage.TwoGuesses (ReferenceVerifierWitness.rootedKey key f) f before.1.1.2
+    (result.before * result.after) before.1.1.1
+
+noncomputable def referenceTwoGuesses {inputs : Finset HashInput} (dummy : OtsReferenceWords)
+    (sample : ReferenceForgerySample inputs) : Prop :=
+  let f := finiteHashAnswer ∅ inputs sample.2.1.2
+  sourceTwoWitnesses sample.1 f (canonicalGraphLabels sample.1.parameter sample.1.otsSecret sample.1.ftsSecret f)
+    sample.2.1.1 dummy sample.2.2
+
+noncomputable def referenceTwoWitnessRest (key : SecretKey) (f : QueryImpl HashSpec Id) (labels : CanonicalGraphLabels)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords) (adversary : Adversary) : ProbComp Bool :=
+  (fun before => decide (sourceTwoWitnesses key f labels selections dummy before)) <$>
+    referenceForgeryRest key f labels selections dummy adversary
+
+theorem rootedKey_programmedHash (key : SecretKey) (labels : CanonicalGraphLabels) (residual : QueryImpl HashSpec Id)
+    (words : OtsReferenceWords) :
+    ReferenceVerifierWitness.rootedKey key (programmedHash key.parameter key.otsSecret key.ftsSecret labels residual) =
+      { key with root := canonicalGraphRoot labels } := by
+  have hroot := ReferenceVerifierWitness.source_root key
+    (programmedHash key.parameter key.otsSecret key.ftsSecret labels residual) words
+  rw [canonicalGraphLabels_programmedHash, reference_root] at hroot
+  change { key with root := (ReferenceVerifierWitness.rootedKey key
+    (programmedHash key.parameter key.otsSecret key.ftsSecret labels residual)).root } = _
+  rw [← hroot]
+
+theorem referenceTwoWitnessRest_program (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary inputs) (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    let f := programmedHash key.parameter key.otsSecret key.ftsSecret labels
+      (finiteHashAnswer ∅ inputs (canonicalReferenceResidual key.parameter inputs hencoding labels auxiliary.rows auxiliary.seed))
+    referenceTwoWitnessRest key f labels auxiliary.selections dummy adversary =
+      (fun result => decide (completedTwoGuesses { key with root := canonicalGraphRoot labels } f result)) <$>
+        simulateQ (fixedAnswers (referenceAnswers key.parameter (canonicalGraphRoot labels) key.otsSecret labels inputs hencoding auxiliary dummy)
+          (FtsGuessSigning.secretTable key.ftsSecret)) (completedRun key.parameter (canonicalGraphRoot labels) labels adversary) := by
+  dsimp only
+  rw [fixed_reference_completedForgeryRest key inputs hencoding labels auxiliary hauxiliary dummy adversary,
+    referenceTwoWitnessRest, Functor.map_map]
+  congr 1
+  funext before
+  rw [sourceTwoWitnesses, rootedKey_programmedHash key labels _ dummy]
+  simp only [completedReferenceContact, reference_root, completedTwoGuesses, completedAtRoot]
+
+theorem referenceTwoWitnessRest_initial_bound (dummy : OtsReferenceWords) (adversary : Adversary) (budget : Nat)
+    (hbudget : HasHashQueryBound scheme adversary budget) (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary (canonicalGraphGameInputs adversary))
+    (hauxiliary : auxiliary ∈ (referenceAuxiliarySample (canonicalGraphGameInputs adversary)).support) :
+    Pr[fun hit => hit = true | 𝒟[sampleFtsSecrets] >>= fun ftsSecret =>
+      𝒟[referenceTwoWitnessRest ⟨parameter, 0, otsSecret, ftsSecret⟩
+        (programmedHash parameter otsSecret ftsSecret labels
+          (finiteHashAnswer ∅ (canonicalGraphGameInputs adversary)
+            (canonicalReferenceResidual parameter (canonicalGraphGameInputs adversary)
+              (canonicalEncodingInputs_subset_gameInputs adversary parameter) labels auxiliary.rows auxiliary.seed)))
+        labels auxiliary.selections dummy adversary]] ≤ pairRate budget := by
+  have h := initial_original_two_witnesses dummy adversary budget hbudget parameter otsSecret labels auxiliary hauxiliary
+  dsimp only at h
+  have hprior := congrArg (fun law : SPMF (Coordinate → Digest) => law >>= fun secrets =>
+      (fun result => (secrets, result)) <$> 𝒟[simulateQ
+        (fixedAnswers (originalAnswers dummy adversary parameter otsSecret labels auxiliary) secrets)
+        (completedRun parameter (canonicalGraphRoot labels) labels adversary)]) FtsGuessSigning.sampleFtsSecrets_table
+  rw [bind_map_left] at hprior
+  rw [← hprior] at h
+  have hprogram (ftsSecret : Index → FtsTree → FtsLeaf → Digest) := referenceTwoWitnessRest_program
+    ⟨parameter, 0, otsSecret, ftsSecret⟩ (canonicalGraphGameInputs adversary)
+    (canonicalEncodingInputs_subset_gameInputs adversary parameter) labels auxiliary hauxiliary dummy adversary
+  simp only [hprogram, evalDist_map, probEvent_bind_eq_tsum, probEvent_map, Function.comp_def,
+    Equiv.symm_apply_apply, decide_eq_true_eq] at h ⊢
+  exact h
+
+private theorem pmf_support {Result : Type} (law : PMF Result) (result : Result) (hr : result ∈ support 𝒟[law]) :
+    result ∈ law.support := by
+  simpa only [mem_support_iff, SPMF.probOutput_eq_apply, SPMF.liftM_apply, PMF.mem_support_iff] using hr
+
+theorem referenceForgeryGame_two_guesses (dummy : OtsReferenceWords) (adversary : Adversary) (budget : Nat)
+    (hbudget : HasHashQueryBound scheme adversary budget) :
+    Pr[referenceTwoGuesses dummy | referenceForgeryGame (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] ≤ pairRate budget := by
+  have hsource := referenceForgeryGame_bind_auxiliary (canonicalGraphGameInputs adversary)
+    (canonicalEncodingInputs_subset_gameInputs adversary) (canonicalGraphInputs_subset_gameInputs adversary) dummy adversary
+    (fun key f labels selections before => pure (decide (sourceTwoWitnesses key f labels selections dummy before)))
+  simp only [evalDist_pure, bind_pure_comp] at hsource
+  have hprojected := congrArg (fun law : SPMF Bool => Pr[fun hit => hit = true | law]) hsource
+  simp only [probEvent_map, Function.comp_def, decide_eq_true_eq] at hprojected
+  change Pr[referenceTwoGuesses dummy | referenceForgeryGame (canonicalGraphGameInputs adversary)
+    (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] = _ at hprojected
+  rw [hprojected]
+  apply probEvent_bind_le_of_forall_le
+  intro parameter _
+  apply probEvent_bind_le_of_forall_le
+  intro otsSecret _
+  rw [RetainedObservation.bind_comm 𝒟[sampleFtsSecrets] 𝒟[referenceAuxiliarySample (canonicalGraphGameInputs adversary)]]
+  apply probEvent_bind_le_of_forall_le
+  intro auxiliary hauxiliary
+  rw [RetainedObservation.bind_comm 𝒟[sampleFtsSecrets] 𝒟[PMF.uniformOfFintype CanonicalGraphLabels]]
+  apply probEvent_bind_le_of_forall_le
+  intro labels _
+  have h := referenceTwoWitnessRest_initial_bound dummy adversary budget hbudget parameter otsSecret labels auxiliary
+    (pmf_support _ auxiliary hauxiliary)
+  simpa only [referenceTwoWitnessRest, evalDist_map] using h
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessProgram.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessProgram.lean
new file mode 100644
index 000000000..e58a8b9b2
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessProgram.lean
@@ -0,0 +1,187 @@
+import SphincsSecurity.Proof.Forced.FtsGuessHash
+import SphincsSecurity.Proof.Reference.ReferenceForgerySource
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec OtsContactTrace
+open FtsGuessSigning (Coordinate)
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] frontierSigningRun frontierRoot maskOtsPrefixes boundaryEval
+
+noncomputable def signingProgram (message : Message) :
+    OracleComp World ((Option Signature × Option FewTimeView) × SigningBoundaryTrace) := do
+  let record ← liftM (World.query (.inl (.inr message)))
+  FtsGuessSigning.completeRecord record
+
+theorem fixed_completeRecord (auxiliary : QueryImpl Auxiliary ProbComp) (secrets : Coordinate → Digest)
+    (record : PublicSigningRecord) :
+    simulateQ (fixedAnswers auxiliary secrets) (FtsGuessSigning.completeRecord record) =
+      pure (completePublicSigningRecord (FtsGuessSigning.secretTable.symm secrets) record) := by
+  obtain ⟨⟨plan, view⟩, trace⟩ := record
+  cases plan <;> cases view <;>
+    simp only [FtsGuessSigning.completeRecord, completePublicSigningRecord, Option.map_none, Option.map_some,
+      simulateQ_pure, simulateQ_bind, fixedAnswers, SecretGuessObservation.fixedAnswers_disclosureSequence, pure_bind]
+  rfl
+
+theorem fixed_signingProgram (auxiliary : QueryImpl Auxiliary ProbComp) (secrets : Coordinate → Digest)
+    (message : Message) :
+    simulateQ (fixedAnswers auxiliary secrets) (signingProgram message) =
+      completePublicSigningRecord (FtsGuessSigning.secretTable.symm secrets) <$> auxiliary (.inr message) := by
+  simp only [signingProgram, simulateQ_bind, simulateQ_spec_query, fixed_completeRecord,
+    fixedAnswers, SecretGuessObservation.fixedAnswers, bind_pure_comp]
+
+abbrev Traced (m : Type → Type) := WriterT SigningBoundaryTrace (WriterT Trace m)
+
+noncomputable def adversaryImpl (parameter : PublicParameter) (labels : CanonicalGraphLabels) :
+    QueryImpl (OracleWorld + SigningSpec) (Traced (OracleComp World))
+  | .inl input => WriterT.mk (WriterT.mk ((fun answer =>
+      ((answer, signingBoundaryTrace parameter input answer), hashObservationTrace input answer)) <$>
+        worldProgram parameter labels input))
+  | .inr message => WriterT.mk (WriterT.mk ((fun record => ((record.1.1, record.2), 1)) <$> signingProgram message))
+
+noncomputable def adversaryRun {Result : Type} (parameter : PublicParameter) (labels : CanonicalGraphLabels)
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) :
+    OracleComp World (((Result × QueryLog SigningSpec) × SigningBoundaryTrace) × Trace) :=
+  ((simulateQ (adversaryImpl parameter labels) (OtsPrefix.logged computation)).run).run
+
+noncomputable def nativeImpl (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (signer : Message → ProbComp (Option Signature × SigningBoundaryTrace)) :
+    QueryImpl (OracleWorld + SigningSpec) (Traced ProbComp)
+  | .inl input => WriterT.mk (WriterT.mk ((fun answer =>
+      ((answer, signingBoundaryTrace parameter input answer), hashObservationTrace input answer)) <$> fixedHashWorld f input))
+  | .inr message => WriterT.mk (WriterT.mk ((fun record => (record, 1)) <$> signer message))
+
+private theorem simulateQ_two_writers {ι₁ ι₂ Result ω₁ ω₂ : Type} {spec₁ : OracleSpec ι₁} {spec₂ : OracleSpec ι₂}
+    {m : Type → Type} [Monad m] [LawfulMonad m] [Monoid ω₁] [Monoid ω₂]
+    (first : QueryImpl spec₁ (WriterT ω₁ (WriterT ω₂ (OracleComp spec₂)))) (second : QueryImpl spec₂ m)
+    (combined : QueryImpl spec₁ (WriterT ω₁ (WriterT ω₂ m)))
+    (hquery : ∀ input, simulateQ second ((first input).run).run = ((combined input).run).run)
+    (computation : OracleComp spec₁ Result) :
+    simulateQ second ((simulateQ first computation).run).run = ((simulateQ combined computation).run).run := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => simp only [simulateQ_pure, WriterT.run_pure]
+  | query_bind input next ih =>
+      simp only [simulateQ_bind, simulateQ_spec_query, WriterT.run_bind, WriterT.run_map,
+        simulateQ_map, hquery]
+      apply bind_congr
+      rintro ⟨⟨answer, first⟩, second⟩
+      rw [ih]
+
+theorem fixed_adversaryImpl (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (labels : CanonicalGraphLabels) (residual : QueryImpl HashSpec Id)
+    (signer : QueryImpl SigningRecordSpec ProbComp) (input : (OracleWorld + SigningSpec).Domain) :
+    simulateQ (fixedAnswers (auxiliaryAnswers parameter otsSecret labels residual signer)
+      (FtsGuessSigning.secretTable ftsSecret)) ((adversaryImpl parameter labels input).run).run =
+      ((nativeImpl parameter (programmedHash parameter otsSecret ftsSecret labels residual)
+        (fun message => (Prod.map Prod.fst id) <$>
+          (completePublicSigningRecord ftsSecret <$> signer message)) input).run).run := by
+  cases input with
+  | inl input =>
+      simp only [adversaryImpl, nativeImpl, WriterT.run_mk, simulateQ_map]
+      rw [FtsGuessHash.fixed_worldProgram parameter otsSecret ftsSecret labels residual signer input]
+  | inr message =>
+      simp only [adversaryImpl, nativeImpl, WriterT.run_mk, simulateQ_map, fixed_signingProgram, auxiliaryAnswers,
+        Functor.map_map]
+      rfl
+
+theorem fixed_adversaryRun {Result : Type} (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (labels : CanonicalGraphLabels) (residual : QueryImpl HashSpec Id)
+    (signer : QueryImpl SigningRecordSpec ProbComp) (computation : OracleComp (OracleWorld + SigningSpec) Result) :
+    simulateQ (fixedAnswers (auxiliaryAnswers parameter otsSecret labels residual signer)
+      (FtsGuessSigning.secretTable ftsSecret)) (adversaryRun parameter labels computation) =
+      ((simulateQ (nativeImpl parameter (programmedHash parameter otsSecret ftsSecret labels residual)
+        (fun message => (Prod.map Prod.fst id) <$>
+          (completePublicSigningRecord ftsSecret <$> signer message))) (OtsPrefix.logged computation)).run).run :=
+  simulateQ_two_writers _ _ _ (fixed_adversaryImpl parameter otsSecret ftsSecret labels residual signer) _
+
+private theorem fixedTrace_query (f : QueryImpl HashSpec Id) (input : OracleWorld.Domain) :
+    fixedTrace f (liftM (OracleWorld.query input)) =
+      (fun answer => (answer, hashObservationTrace input answer)) <$> fixedHashWorld f input := by
+  simp [fixedTrace, QueryPause.traced, QueryImpl.withTrace_apply]
+
+private theorem fixedTrace_lift_prob {Result : Type} (f : QueryImpl HashSpec Id) (computation : ProbComp Result) :
+    fixedTrace f (liftM computation) = (fun answer => (answer, (1 : Trace))) <$> computation := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => simp only [liftM_pure, fixedTrace_pure, map_pure]
+  | query_bind input next ih =>
+      rw [liftM_bind, fixedTrace_bind]
+      change (fixedTrace f (liftM (OracleWorld.query (.inl input))) >>= _) = _
+      rw [fixedTrace_query]
+      simp only [hashObservationTrace, fixedHashWorld, ih, Functor.map_map, map_bind]
+      rw [map_eq_bind_pure_comp, bind_assoc]
+      simp only [Function.comp_def, pure_bind, one_mul]
+      rfl
+
+private theorem fixedTrace_writer {Result : Type}
+    (f : QueryImpl HashSpec Id)
+    (first : QueryImpl (OracleWorld + SigningSpec) (WriterT SigningBoundaryTrace (OracleComp OracleWorld)))
+    (second : QueryImpl (OracleWorld + SigningSpec) (Traced ProbComp))
+    (hquery : ∀ input, fixedTrace f (first input).run = ((second input).run).run)
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) :
+    fixedTrace f (simulateQ first computation).run = ((simulateQ second computation).run).run := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => simp only [simulateQ_pure, WriterT.run_pure, fixedTrace_pure]
+  | query_bind input next ih =>
+      simp only [simulateQ_bind, simulateQ_spec_query, WriterT.run_bind, WriterT.run_map,
+        fixedTrace_bind, fixedTrace_map, hquery]
+      apply bind_congr
+      rintro ⟨⟨answer, first⟩, second⟩
+      simp only [ih, Functor.map_map]
+
+noncomputable def sourceImpl (parameter : PublicParameter)
+    (signer : Message → ProbComp (Option Signature × SigningBoundaryTrace)) :
+    QueryImpl (OracleWorld + SigningSpec) (WriterT SigningBoundaryTrace (OracleComp OracleWorld))
+  | .inl input => (QueryImpl.id' OracleWorld).withTrace (signingBoundaryTrace parameter) input
+  | .inr message => WriterT.mk (liftM (signer message))
+
+private theorem native_sourceQuery (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (signer : Message → ProbComp (Option Signature × SigningBoundaryTrace)) (input : (OracleWorld + SigningSpec).Domain) :
+    fixedTrace f (sourceImpl parameter signer input).run = ((nativeImpl parameter f signer input).run).run := by
+  cases input with
+  | inl input =>
+      have h : (sourceImpl parameter signer (.inl input)).run =
+          (fun answer => (answer, signingBoundaryTrace parameter input answer)) <$> liftM (OracleWorld.query input) := by
+        simp [sourceImpl, QueryImpl.withTrace_apply]
+      rw [h, fixedTrace_map, fixedTrace_query]
+      simp only [nativeImpl, WriterT.run_mk, Functor.map_map]
+      rfl
+  | inr message => exact fixedTrace_lift_prob f (signer message)
+
+theorem native_adversaryRun {Result : Type} (parameter : PublicParameter) (root : Digest)
+    (f : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) :
+    fixedTrace f (CausalFrontierProgram.adversaryRun parameter root f ftsSecret words frontier computation) =
+      ((simulateQ (nativeImpl parameter f
+        (frontierSigningRun parameter root (maskOtsPrefixes parameter words f) ftsSecret words frontier))
+        (OtsPrefix.logged computation)).run).run :=
+  fixedTrace_writer f (sourceImpl parameter
+    (frontierSigningRun parameter root (maskOtsPrefixes parameter words f) ftsSecret words frontier)) _
+    (native_sourceQuery parameter f _) (OtsPrefix.logged computation)
+
+noncomputable def verifyProgram (parameter : PublicParameter) (root : Digest) (labels : CanonicalGraphLabels)
+    (forgery : Forgery) : OracleComp World ((Bool × SigningBoundaryTrace) × Trace) :=
+  simulateQ (worldProgram parameter labels) (QueryPause.traced hashObservationTrace
+    (boundaryComputation parameter (liftM (verify ⟨root, parameter⟩ forgery.message forgery.signature : OracleComp HashSpec Bool))))
+
+theorem fixed_verifyProgram (parameter : PublicParameter) (root : Digest)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (labels : CanonicalGraphLabels) (residual : QueryImpl HashSpec Id)
+    (signer : QueryImpl SigningRecordSpec ProbComp) (forgery : Forgery) :
+    simulateQ (fixedAnswers (auxiliaryAnswers parameter otsSecret labels residual signer)
+      (FtsGuessSigning.secretTable ftsSecret)) (verifyProgram parameter root labels forgery) =
+      pure (boundaryEval parameter (programmedHash parameter otsSecret ftsSecret labels residual)
+        (verify ⟨root, parameter⟩ forgery.message forgery.signature),
+        answerTrace (programmedHash parameter otsSecret ftsSecret labels residual)
+          (verify ⟨root, parameter⟩ forgery.message forgery.signature)) := by
+  rw [verifyProgram, fixed_world_translate]
+  exact fixedTrace_boundary_hash parameter _ _
+
+noncomputable def completedRun (parameter : PublicParameter) (root : Digest) (labels : CanonicalGraphLabels)
+    (adversary : Adversary) : OracleComp World (AdversaryTrace × (Bool × SigningBoundaryTrace) × Trace) := do
+  let before ← adversaryRun parameter labels (adversary.main ⟨root, parameter⟩)
+  let checked ← verifyProgram parameter root labels before.1.1.1
+  pure (before, checked)
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessProposalCompleted.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessProposalCompleted.lean
new file mode 100644
index 000000000..b371d45fe
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessProposalCompleted.lean
@@ -0,0 +1,266 @@
+import SphincsSecurity.Proof.Forced.FtsGuessProposalPayment
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec UniformTableCompletion OtsContactTrace ENNReal
+open FtsGuessSigning (Coordinate)
+open FtsProbeSimulation (MessageHashInput messageAnswers)
+open SecretGuessObservation (State)
+open RetainedResidual (proposalStop)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  publicDigestLoop canonicalGraphRoot canonicalGraphInput hashInputs UniformTableCompletion.complete signDigestLoop
+
+variable (parameter : PublicParameter) (root : Digest)
+  (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+  (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+  (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (dummy : OtsReferenceWords) (slot : Nat)
+  (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+/-! ### Creation mass along the verifier -/
+
+theorem expected_monitoredWorldStep_creationMass (input : OracleWorld.Domain) (state : MonitoredState) (hvalid : Valid state) :
+    (∑' result, Pr[= result | monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter input state] * result.2.2.creationMass) =
+      state.2.creationMass + certificateMonitorMass (monitorKey parameter root) budget (.inl input) (monitorView state) := by
+  rw [← monitoredStep_inl]
+  calc
+    _ = ∑' result, Pr[= result | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter (.inl input) state] *
+        (state.2.creationMass + certificateMonitorMass (monitorKey parameter root) budget (.inl input) (monitorView state)) := by
+      apply tsum_congr
+      intro result
+      by_cases hr : Pr[= result | monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter (.inl input) state] = 0
+      · simp only [hr, zero_mul]
+      · rw [SPMF.probOutput_eq_apply] at hr
+        rw [(monitoredStep_creation_counters parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter (.inl input) state result hr).2]
+    _ = _ := by
+      rw [ENNReal.tsum_mul_right, tsum_monitoredStep_eq_one parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+        required stopAfter (.inl input) state hvalid, one_mul]
+
+theorem expected_monitoredWorldRun_creationMass {Result : Type} (computation : OracleComp OracleWorld Result) (state : MonitoredState)
+    (hvalid : Valid state) :
+    (∑' result, Pr[= result | monitoredWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter computation state] * result.2.2.creationMass) =
+      state.2.creationMass +
+        expectedWorldPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          (certificateMonitorMass (monitorKey parameter root) budget) computation state :=
+  expected_monitoredWorldRun_accumulator parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+    CertificateMonitor.creationMass (certificateMonitorMass (monitorKey parameter root) budget)
+    (fun input state hvalid => expected_monitoredWorldStep_creationMass parameter root otsSecret labels inputs hencoding selections rows dummy
+      slot budget required stopAfter input state hvalid) computation state hvalid
+
+theorem expectedWorldPayment_mul (charge : (OracleWorld + SigningSpec).Domain → CertificateMonitorState → ENNReal) (rate : ENNReal)
+    {Result : Type} (computation : OracleComp OracleWorld Result) (state : MonitoredState) :
+    expectedWorldPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      (fun input current => charge input current * rate) computation state =
+      expectedWorldPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter charge
+        computation state * rate := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => exact (zero_mul _).symm
+  | query_bind input next ih =>
+      rw [expectedWorldPayment_query_bind, expectedWorldPayment_query_bind, add_mul, ← ENNReal.tsum_mul_right]
+      congr 1
+      apply tsum_congr
+      intro result
+      rw [ih result.1.1.1 result.2, mul_assoc]
+
+/-! ### The proposal invariant along the verifier -/
+
+theorem monitoredWorldStep_invariant (total : Nat) (word : List Index) (input : OracleWorld.Domain) (state : MonitoredState)
+    (hinputs : hashInputs (liftM (OracleWorld.query input)) ⊆ inputs) (hinv : ProposalInvariant parameter root total (word, state))
+    (result : AdversaryStep (.inl input) × MonitoredState)
+    (hresult : monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+      (proposalStop stopAfter) input state result ≠ 0) :
+    ProposalInvariant parameter root total (word, result.2) := by
+  rw [monitoredWorldStep] at hresult
+  obtain ⟨raw, hraw, rfl⟩ := map_nonzero_source' _ _ _ hresult
+  exact worldStep_proposalInvariant parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter total
+    input (word, state) hinputs hinv raw hraw
+
+theorem expectedWorldPayment_charge_le_mass_terminalPotential (total : Nat) (word : List Index) {Result : Type}
+    (computation : OracleComp OracleWorld Result) (state : MonitoredState) (hvalid : Valid state)
+    (hinputs : hashInputs computation ⊆ inputs) (hbudget : budget ≤ 2 ^ 127)
+    (hinv : ProposalInvariant parameter root total (word, state)) :
+    expectedWorldPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required (proposalStop stopAfter)
+      (certificateMonitorCharge (monitorKey parameter root) budget required) computation state ≤
+      expectedWorldPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required (proposalStop stopAfter)
+        (fun input current => certificateMonitorMass (monitorKey parameter root) budget input current *
+          terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice required) word) computation state := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => exact le_rfl
+  | query_bind input next ih =>
+      rw [expectedWorldPayment_query_bind, expectedWorldPayment_query_bind]
+      apply add_le_add (certificateMonitorCharge_le_terminalPrice_of_invariant (monitorKey parameter root) budget total required (.inl input)
+        (word, monitorView state) hbudget hinv)
+      apply ENNReal.tsum_le_tsum
+      intro result
+      by_cases hr : Pr[= result | monitoredWorldStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          (proposalStop stopAfter) input state] = 0
+      · simp only [hr, zero_mul, le_refl]
+      · rw [SPMF.probOutput_eq_apply] at hr
+        apply mul_le_mul' le_rfl
+        exact ih result.1.1.1 result.2
+          (monitoredStep_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required (proposalStop stopAfter)
+            (.inl input) state hvalid result hr)
+          ((hashInputs_world_next input next result.1.1.1).trans hinputs)
+          (monitoredWorldStep_invariant parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter total
+            word input state ((hashInputs_world_query input next).trans hinputs) hinv result hr)
+
+/-! ### The completed proposal run -/
+
+variable (hauxiliary : ∀ seed : inputs → HashOutput,
+  (⟨selections, rows, seed⟩ : ReferenceAuxiliary inputs) ∈ (referenceAuxiliarySample inputs).support)
+
+theorem expected_proposalCompletedRun_mass_terminalPotential (total : Nat) (adversary : Adversary) (state : ProposalState)
+    (hvalid : Valid state.2) :
+    (∑' result, Pr[= result | proposalCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter adversary state] *
+      (result.2.2.2.creationMass * terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice required) result.2.1)) =
+      ∑' before, Pr[= before | proposalRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        (adversary.main ⟨root, parameter⟩) state] *
+        ((before.2.2.2.creationMass +
+          expectedWorldPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+            (certificateMonitorMass (monitorKey parameter root) budget) (verifyComputation parameter root before.1.1.1.1) before.2.2) *
+          terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice required) before.2.1) := by
+  rw [proposalCompletedRun, tsum_probOutput_bind_mul]
+  apply tsum_congr
+  intro before
+  by_cases hb : Pr[= before | proposalRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      (adversary.main ⟨root, parameter⟩) state] = 0
+  · simp only [hb, zero_mul]
+  · rw [SPMF.probOutput_eq_apply] at hb
+    apply congrArg (_ * ·)
+    rw [tsum_probOutput_map_mul]
+    have hvalid' := monitoredRun_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      (adversary.main ⟨root, parameter⟩) state.2 hvalid _
+      (proposalRun_forced parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        (adversary.main ⟨root, parameter⟩) state before hb)
+    calc
+      _ = ∑' checked, Pr[= checked | monitoredWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+            stopAfter (verifyComputation parameter root before.1.1.1.1) before.2.2] * checked.2.2.creationMass *
+          terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice required) before.2.1 := by
+        apply tsum_congr
+        intro checked
+        rw [mul_assoc]
+      _ = _ := by
+        rw [ENNReal.tsum_mul_right, expected_monitoredWorldRun_creationMass parameter root otsSecret labels inputs hencoding selections rows dummy
+          slot budget required stopAfter _ before.2.2 hvalid']
+
+include hauxiliary in
+theorem expected_proposalCompletedRun_creationCost (adversary : Adversary) (state : ProposalState) (hvalid : Valid state.2)
+    (hcovered : CoveredRun parameter root otsSecret inputs (adversary.main ⟨root, parameter⟩) state.2) :
+    (∑' result, Pr[= result | proposalCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter adversary state] * result.2.2.2.creationCost) =
+      state.2.2.creationCost +
+        (expectedProposalPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          (fun input current => certificateMonitorCharge (monitorKey parameter root) budget required input (monitorView current.2))
+          (adversary.main ⟨root, parameter⟩) state +
+        ∑' before, Pr[= before | proposalRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          (adversary.main ⟨root, parameter⟩) state] *
+          expectedWorldPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+            (certificateMonitorCharge (monitorKey parameter root) budget required) (verifyComputation parameter root before.1.1.1.1) before.2.2) := by
+  rw [proposalCompletedRun, tsum_probOutput_bind_mul]
+  calc
+    _ = ∑' before, Pr[= before | proposalRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          (adversary.main ⟨root, parameter⟩) state] *
+        (before.2.2.2.creationCost +
+          expectedWorldPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+            (certificateMonitorCharge (monitorKey parameter root) budget required) (verifyComputation parameter root before.1.1.1.1) before.2.2) := by
+      apply tsum_congr
+      intro before
+      by_cases hb : Pr[= before | proposalRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          (adversary.main ⟨root, parameter⟩) state] = 0
+      · simp only [hb, zero_mul]
+      · rw [SPMF.probOutput_eq_apply] at hb
+        apply congrArg (_ * ·)
+        rw [tsum_probOutput_map_mul]
+        exact expected_monitoredWorldRun_creationCost parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter _ before.2.2
+          (monitoredRun_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+            (adversary.main ⟨root, parameter⟩) state.2 hvalid _
+            (proposalRun_forced parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+              (adversary.main ⟨root, parameter⟩) state before hb))
+    _ = _ := by
+      simp only [mul_add, ENNReal.tsum_add]
+      rw [expected_proposalRun_creationCost parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        hauxiliary (adversary.main ⟨root, parameter⟩) state hvalid hcovered, add_assoc]
+
+include hauxiliary in
+theorem expected_proposalCompletedRun_creationCost_le_mass_terminalPotential (total : Nat) (adversary : Adversary) (state : ProposalState)
+    (hvalid : Valid state.2) (hcovered : CoveredRun parameter root otsSecret inputs (adversary.main ⟨root, parameter⟩) state.2)
+    (hbudget : budget ≤ 2 ^ 127) (hinv : ProposalInvariant parameter root total state) :
+    (∑' result, Pr[= result | proposalCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        (proposalStop stopAfter) adversary state] * result.2.2.2.creationCost) ≤
+      state.2.2.creationCost +
+        ∑' result, Pr[= result | proposalCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          (proposalStop stopAfter) adversary state] *
+          (result.2.2.2.creationMass * terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice required) result.2.1) := by
+  rw [expected_proposalCompletedRun_creationCost parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+      (proposalStop stopAfter) hauxiliary adversary state hvalid hcovered,
+    expected_proposalCompletedRun_mass_terminalPotential parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+      (proposalStop stopAfter) total adversary state hvalid]
+  apply add_le_add le_rfl
+  have hmain := expectedProposalPayment_charge_le_mass_terminalPotential parameter root otsSecret labels inputs hencoding selections rows dummy slot
+    budget required stopAfter hauxiliary total (adversary.main ⟨root, parameter⟩) state hvalid hcovered hbudget hinv
+  have hmass := expected_proposalRun_mass_terminalPotential parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+    required (proposalStop stopAfter) hauxiliary total (adversary.main ⟨root, parameter⟩) state hvalid hcovered
+  have hworld : (∑' before, Pr[= before | proposalRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        (proposalStop stopAfter) (adversary.main ⟨root, parameter⟩) state] *
+        expectedWorldPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required (proposalStop stopAfter)
+          (certificateMonitorCharge (monitorKey parameter root) budget required) (verifyComputation parameter root before.1.1.1.1) before.2.2) ≤
+      ∑' before, Pr[= before | proposalRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        (proposalStop stopAfter) (adversary.main ⟨root, parameter⟩) state] *
+        (expectedWorldPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required (proposalStop stopAfter)
+          (certificateMonitorMass (monitorKey parameter root) budget) (verifyComputation parameter root before.1.1.1.1) before.2.2 *
+          terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice required) before.2.1) := by
+    apply ENNReal.tsum_le_tsum
+    intro before
+    by_cases hb : Pr[= before | proposalRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        (proposalStop stopAfter) (adversary.main ⟨root, parameter⟩) state] = 0
+    · simp only [hb, zero_mul, le_refl]
+    · rw [SPMF.probOutput_eq_apply] at hb
+      apply mul_le_mul' le_rfl
+      have hforced := proposalRun_forced parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        (proposalStop stopAfter) (adversary.main ⟨root, parameter⟩) state before hb
+      have hvalid' := monitoredRun_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        (proposalStop stopAfter) (adversary.main ⟨root, parameter⟩) state.2 hvalid _ hforced
+      have hfinal := monitoredRun_covered parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        (proposalStop stopAfter) hauxiliary (adversary.main ⟨root, parameter⟩) state.2 hvalid hcovered _ hforced
+      have hinv' := proposalRun_invariant parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        hauxiliary total (adversary.main ⟨root, parameter⟩) state hvalid hcovered hinv before hb
+      rw [← expectedWorldPayment_mul]
+      exact expectedWorldPayment_charge_le_mass_terminalPotential parameter root otsSecret labels inputs hencoding selections rows dummy slot
+        budget required stopAfter total before.2.1 (verifyComputation parameter root before.1.1.1.1) before.2.2 hvalid'
+        (covered_pure parameter root otsSecret inputs before.1.1.1.1 before.2.2 hvalid' hfinal) hbudget hinv'
+  calc
+    _ ≤ expectedProposalPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          (proposalStop stopAfter)
+          (fun input current => certificateMonitorMass (monitorKey parameter root) budget input (monitorView current.2) *
+            terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice required) current.1)
+          (adversary.main ⟨root, parameter⟩) state +
+        ∑' before, Pr[= before | proposalRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          (proposalStop stopAfter) (adversary.main ⟨root, parameter⟩) state] *
+          (expectedWorldPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required (proposalStop stopAfter)
+            (certificateMonitorMass (monitorKey parameter root) budget) (verifyComputation parameter root before.1.1.1.1) before.2.2 *
+            terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice required) before.2.1) :=
+      add_le_add hmain hworld
+    _ ≤ (state.2.2.creationMass * terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice required) state.1 +
+          expectedProposalPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+            (proposalStop stopAfter)
+            (fun input current => certificateMonitorMass (monitorKey parameter root) budget input (monitorView current.2) *
+              terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice required) current.1)
+            (adversary.main ⟨root, parameter⟩) state) +
+        ∑' before, Pr[= before | proposalRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          (proposalStop stopAfter) (adversary.main ⟨root, parameter⟩) state] *
+          (expectedWorldPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required (proposalStop stopAfter)
+            (certificateMonitorMass (monitorKey parameter root) budget) (verifyComputation parameter root before.1.1.1.1) before.2.2 *
+            terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice required) before.2.1) :=
+      add_le_add le_add_self le_rfl
+    _ = _ := by
+      rw [← hmass]
+      simp only [add_mul, mul_add, ENNReal.tsum_add]
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessProposalInvariant.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessProposalInvariant.lean
new file mode 100644
index 000000000..1d313c456
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessProposalInvariant.lean
@@ -0,0 +1,233 @@
+import SphincsSecurity.Proof.Forced.FtsGuessProposalStep
+import SphincsSecurity.Proof.Residual.RetainedResidualProposalInvariant
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec UniformTableCompletion OtsContactTrace ENNReal
+open FtsGuessSigning (Coordinate)
+open FtsProbeSimulation (MessageHashInput messageAnswers)
+open SecretGuessObservation (State)
+open RetainedResidual (proposalOfSigningRecord proposalOfWorldResult signingAnnotation completeRecordIndex attachRejectedWord proposalStop
+  proposalStop_eq)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  publicDigestLoop canonicalGraphRoot canonicalGraphInput hashInputs UniformTableCompletion.complete signDigestLoop
+
+variable (parameter : PublicParameter) (root : Digest)
+  (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+  (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+  (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (dummy : OtsReferenceWords) (slot : Nat)
+  (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+/-! ### World steps keep the observed signing views -/
+
+theorem worldStep_cache_le (input : OracleWorld.Domain) (state : MonitoredState)
+    (hinputs : hashInputs (liftM (OracleWorld.query input)) ⊆ inputs) (result : OracleWorld.Range input × CachedState)
+    (hresult : cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot (worldProgram parameter labels input)
+      state.1 result ≠ 0) :
+    state.1.1 ≤ result.2.1 ∧ (messageAnswers parameter result.2.1 = messageAnswers parameter state.1.1 ∨
+      ∃ hash, input = .inr hash ∧ MessageHashInput parameter hash) := by
+  cases input with
+  | inl sample =>
+      rw [cachedForcedRun_world_unif'] at hresult
+      obtain ⟨answer, _, rfl⟩ := map_nonzero_source' _ _ _ hresult
+      exact ⟨le_rfl, Or.inl rfl⟩
+  | inr hash =>
+      have hsupport := cachedForcedRun_world_hash_support' parameter root otsSecret labels inputs hencoding selections rows dummy slot hash
+        state.1 result hresult
+      refine ⟨hsupport.2.1, ?_⟩
+      by_cases hmessage : MessageHashInput parameter hash
+      · exact Or.inr ⟨hash, rfl, hmessage⟩
+      · exact Or.inl (messageAnswers_eq_of_cache_of_ne parameter state.1.1 result.2.1 hash hmessage hsupport.1)
+
+theorem worldStep_observedViews (input : OracleWorld.Domain) (state : MonitoredState)
+    (hinputs : hashInputs (liftM (OracleWorld.query input)) ⊆ inputs) (log : QueryLog SigningSpec)
+    (hsigned : SigningDigestsCached parameter state.1.1 root log) (result : OracleWorld.Range input × CachedState)
+    (hresult : cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot (worldProgram parameter labels input)
+      state.1 result ≠ 0) :
+    observedOptionalSigningViews (messageAnswers parameter result.2.1) root log =
+      observedOptionalSigningViews (messageAnswers parameter state.1.1) root log := by
+  obtain ⟨hle, _⟩ := worldStep_cache_le parameter root otsSecret labels inputs hencoding selections rows dummy slot input state hinputs result hresult
+  exact observedOptionalSigningViews_cache_stable parameter root _ _ log hle hsigned
+
+theorem worldStep_digestsCached (input : OracleWorld.Domain) (state : MonitoredState)
+    (hinputs : hashInputs (liftM (OracleWorld.query input)) ⊆ inputs) (log : QueryLog SigningSpec)
+    (hsigned : SigningDigestsCached parameter state.1.1 root log) (result : OracleWorld.Range input × CachedState)
+    (hresult : cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot (worldProgram parameter labels input)
+      state.1 result ≠ 0) :
+    SigningDigestsCached parameter result.2.1 root log :=
+  hsigned.mono (worldStep_cache_le parameter root otsSecret labels inputs hencoding selections rows dummy slot input state hinputs result hresult).1
+
+/-! ### Signing steps add one observed view at the proposed index -/
+
+theorem forcedSigning_cache_le (message : Message) (state : MonitoredState) (hvalid : Valid state)
+    (hinputs : hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs)
+    (result : ((Option Signature × Option FewTimeView) × SigningBoundaryTrace) × CachedState)
+    (hresult : forcedSigning parameter root otsSecret labels inputs hencoding selections rows dummy slot message state result ≠ 0) :
+    state.1.1 ≤ result.2.1 := by
+  obtain ⟨loop, hloop, hcache, _⟩ := forcedSigning_digestRecord parameter root otsSecret labels inputs hencoding selections rows dummy slot
+    message state hvalid hinputs result hresult
+  rw [hcache]
+  exact simulateQ_romImpl_cache_le _ _ _ hloop
+
+theorem forcedSigning_digestsCached (message : Message) (state : MonitoredState) (hvalid : Valid state)
+    (hinputs : hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs) (log : QueryLog SigningSpec)
+    (hsigned : SigningDigestsCached parameter state.1.1 root log)
+    (result : ((Option Signature × Option FewTimeView) × SigningBoundaryTrace) × CachedState)
+    (hresult : forcedSigning parameter root otsSecret labels inputs hencoding selections rows dummy slot message state result ≠ 0) :
+    SigningDigestsCached parameter result.2.1 root (log ++ [⟨message, result.1.1.1⟩]) := by
+  obtain ⟨loop, hloop, hcache, hcompletion⟩ := forcedSigning_digestRecord parameter root otsSecret labels inputs hencoding selections rows dummy
+    slot message state hvalid hinputs result hresult
+  have hle : state.1.1 ≤ result.2.1 := by
+    rw [hcache]
+    exact simulateQ_romImpl_cache_le _ _ _ hloop
+  intro entry hentry signature hsignature
+  rcases List.mem_append.mp hentry with hold | hnew
+  · exact (hsigned.mono hle) entry hold signature hsignature
+  · obtain rfl := List.mem_singleton.mp hnew
+    obtain ⟨output, houtput, _, _⟩ := digestCompletion_successful_cached_output (monitorKey parameter root) message state.1.1 loop hloop
+      (result.1.1, result.2.1) hcompletion signature hsignature
+    exact Option.ne_none_iff_exists'.mpr ⟨output, houtput⟩
+
+theorem completedForcedSigning_observed_index (message : Message) (state : MonitoredState) (hvalid : Valid state)
+    (hinputs : hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs)
+    (result : (((Option Signature × Option FewTimeView) × SigningBoundaryTrace) × CachedState) × Index)
+    (hresult : completedForcedSigning parameter root otsSecret labels inputs hencoding selections rows dummy slot message state result ≠ 0)
+    (view : FewTimeView)
+    (hview : observedSigningView? (messageAnswers parameter result.1.2.1) root ⟨message, result.1.1.1.1⟩ = some view) :
+    result.2 = view.1 := by
+  have hraw := map_nonzero_of _ Prod.fst result hresult
+  rw [completedForcedSigning_record] at hraw
+  obtain ⟨loop, hloop, _, hcompletion⟩ := forcedSigning_digestRecord parameter root otsSecret labels inputs hencoding selections rows dummy slot
+    message state hvalid hinputs result.1 hraw
+  cases hs : result.1.1.1.1 with
+  | none => simp [observedSigningView?, hs] at hview
+  | some signature =>
+      obtain ⟨output, houtput, _, hselected⟩ := digestCompletion_successful_cached_output (monitorKey parameter root) message state.1.1 loop
+        hloop (result.1.1.1, result.1.2.1) hcompletion signature hs
+      dsimp only at houtput hselected
+      have houtput' : result.1.2.1 (tweakableHashInput parameter .message (messageDigestPayload root message signature.randomness)) =
+          some output := houtput
+      have hv : hashOutputFewTimeView output = view := by
+        simpa [observedSigningView?, hs, messageAnswers, houtput'] using hview
+      have hselected' : forcedSigningView result.1 = some (hashOutputFewTimeView output) := hselected
+      exact (RetainedResidual.completeRecordIndex_selected _ forcedSigningView result hresult _ hselected').trans (congrArg Prod.fst hv)
+
+theorem completedForcedSigning_slots_le (message : Message) (state : MonitoredState) (hvalid : Valid state)
+    (hinputs : hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs)
+    (log : QueryLog SigningSpec) (hsigned : SigningDigestsCached parameter state.1.1 root log)
+    (result : (((Option Signature × Option FewTimeView) × SigningBoundaryTrace) × CachedState) × Index)
+    (hresult : completedForcedSigning parameter root otsSecret labels inputs hencoding selections rows dummy slot message state result ≠ 0)
+    (index : Index) :
+    (signingSlotsAtIndex (observedOptionalSigningViews (messageAnswers parameter result.1.2.1) root
+      (log ++ [⟨message, result.1.1.1.1⟩])) index).card ≤
+        (signingSlotsAtIndex (observedOptionalSigningViews (messageAnswers parameter state.1.1) root log) index).card +
+          if result.2 = index then 1 else 0 := by
+  have hraw := map_nonzero_of _ Prod.fst result hresult
+  rw [completedForcedSigning_record] at hraw
+  have hle := forcedSigning_cache_le parameter root otsSecret labels inputs hencoding selections rows dummy slot message state hvalid hinputs
+    result.1 hraw
+  have hstable := observedOptionalSigningViews_cache_stable parameter root _ _ log hle hsigned
+  unfold observedOptionalSigningViews
+  rw [signingSlotsAtIndex_log_append_card]
+  have heq := congrArg (fun views => (signingSlotsAtIndex views index).card) hstable
+  apply Nat.add_le_add heq.le
+  split_ifs with hobserved hindex hindex
+  · exact le_rfl
+  · obtain ⟨view, hview, hsource⟩ := hobserved
+    exact False.elim (hindex ((completedForcedSigning_observed_index parameter root otsSecret labels inputs hencoding selections rows dummy
+      slot message state hvalid hinputs result hresult view hview).trans hsource))
+  · exact Nat.zero_le _
+  · exact le_rfl
+
+/-! ### The proposal invariant -/
+
+def ProposalInvariant (total : Nat) (state : ProposalState) : Prop :=
+  CertificateProposalInvariant (monitorKey parameter root) total (state.1, monitorView state.2)
+
+theorem worldStep_proposalInvariant (total : Nat) (input : OracleWorld.Domain) (state : ProposalState)
+    (hinputs : hashInputs (liftM (OracleWorld.query input)) ⊆ inputs) (hinv : ProposalInvariant parameter root total state)
+    (result : OracleWorld.Range input × CachedState)
+    (hresult : cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot (worldProgram parameter labels input)
+      state.2.1 result ≠ 0) :
+    ProposalInvariant parameter root total (state.1,
+      (result.2, certificateMonitorUpdate (monitorKey parameter root) budget required (proposalStop stopAfter) (.inl input)
+        (monitorView state.2) 0 (proposalOfWorldResult parameter input (result.1, result.2.1)))) := by
+  by_cases hactive : CertificateMonitorActive (monitorKey parameter root) budget (.inl input) (monitorView state.2)
+  · have hbefore := hinv hactive.1
+    have hstable := worldStep_observedViews parameter root otsSecret labels inputs hencoding selections rows dummy slot input state.2 hinputs
+      state.2.2.log hactive.2.1.1 result hresult
+    have hafter := certificateProposalInvariant_advance (monitorKey parameter root) budget total required stopAfter (.inl input)
+      (state.1, monitorView state.2) [] 0 (proposalOfWorldResult parameter input (result.1, result.2.1)) hinv hactive rfl
+      (fun index => by
+        change (signingSlotsAtIndex (observedOptionalSigningViews (messageAnswers parameter result.2.1) root (state.2.2.log ++ [])) index).card ≤
+          (state.1 ++ []).count index
+        rw [List.append_nil, List.append_nil, hstable]
+        exact hbefore.counts_le index)
+    rw [← proposalStop_eq] at hafter
+    simpa only [ProposalInvariant, originalProposalAdvance, monitorView, proposalOfWorldResult, List.append_nil] using hafter
+  · intro hpost
+    change (certificateMonitorUpdate (monitorKey parameter root) budget required (proposalStop stopAfter) (.inl input) (monitorView state.2) 0
+      (proposalOfWorldResult parameter input (result.1, result.2.1))).stopped = false at hpost
+    simp only [certificateMonitorUpdate, if_neg hactive, Bool.true_eq_false] at hpost
+
+theorem signStep_proposalInvariant (total : Nat) (message : Message) (state : ProposalState) (hvalid : Valid state.2)
+    (hinputs : hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs)
+    (hinv : ProposalInvariant parameter root total state)
+    (hactive : CertificateMonitorActive (monitorKey parameter root) budget (.inr message) (monitorView state.2))
+    (word : List Index) (result : (((Option Signature × Option FewTimeView) × SigningBoundaryTrace) × CachedState) × Index)
+    (hresult : completedForcedSigning parameter root otsSecret labels inputs hencoding selections rows dummy slot message state.2 result ≠ 0) :
+    ProposalInvariant parameter root total (state.1 ++ (word ++ [result.2]),
+      (signResult parameter root budget required (proposalStop stopAfter) message (word.length + 1, result.2) state.2 result.1).2) := by
+  have heffective : result.1.1.1.2.elim result.2 Prod.fst = result.2 :=
+    RetainedResidual.completeRecordIndex_effective _ forcedSigningView result hresult
+  have hbefore := hinv hactive.1
+  have hafter := certificateProposalInvariant_advance (monitorKey parameter root) budget total required stopAfter (.inr message)
+    (state.1, monitorView state.2) (word ++ [result.2]) (word.length + 1)
+    (proposalOfSigningRecord message result.1.1 result.1.2.1 result.2) hinv hactive
+    (by simp only [List.length_append, List.length_singleton]) (fun index => by
+      have hc := completedForcedSigning_slots_le parameter root otsSecret labels inputs hencoding selections rows dummy slot message state.2
+        hvalid hinputs state.2.2.log hactive.2.1.1 result hresult index
+      calc
+        _ ≤ _ := hc
+        _ ≤ state.1.count index + if result.2 = index then 1 else 0 := Nat.add_le_add_right (hbefore.counts_le index) _
+        _ ≤ (state.1 ++ (word ++ [result.2])).count index := by
+          simp only [List.count_append, List.count_cons, List.count_nil, beq_iff_eq]
+          split_ifs <;> omega)
+  rw [← proposalStop_eq] at hafter
+  simpa only [ProposalInvariant, signResult, heffective, originalProposalAdvance, monitorView, proposalOfSigningRecord] using hafter
+
+theorem proposalStep_invariant (total : Nat) (input : (OracleWorld + SigningSpec).Domain) (state : ProposalState) (hvalid : Valid state.2)
+    (hworld : ∀ world, input = .inl world → hashInputs (liftM (OracleWorld.query world)) ⊆ inputs)
+    (hsign : ∀ message, input = .inr message → hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs)
+    (hinv : ProposalInvariant parameter root total state) (result : AdversaryStep input × ProposalState)
+    (hresult : proposalStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required (proposalStop stopAfter)
+      input state result ≠ 0) :
+    ProposalInvariant parameter root total result.2 := by
+  cases input with
+  | inl input =>
+      rw [proposalStep] at hresult
+      obtain ⟨middle, hmiddle, rfl⟩ := map_nonzero_source' _ _ _ hresult
+      rw [monitoredStep, monitoredWorldStep] at hmiddle
+      obtain ⟨raw, hraw, rfl⟩ := map_nonzero_source' _ _ _ hmiddle
+      exact worldStep_proposalInvariant parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        total input state (hworld input rfl) hinv raw hraw
+  | inr message =>
+      rw [proposalStep] at hresult
+      split_ifs at hresult with hactive
+      · obtain ⟨source, hsource, rfl⟩ := map_nonzero_source' _ _ _ hresult
+        have hrecord := map_nonzero_of _ Prod.snd source hsource
+        rw [RetainedResidual.attachRejectedWord_record] at hrecord
+        exact signStep_proposalInvariant parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          total message state hvalid (hsign message rfl) hinv hactive source.1 source.2 hrecord
+      · obtain ⟨middle, hmiddle, rfl⟩ := map_nonzero_source' _ _ _ hresult
+        rw [monitoredStep, monitoredSignStep, RetainedObservation.bind_nonzero] at hmiddle
+        obtain ⟨annotation, _, hmiddle⟩ := hmiddle
+        obtain ⟨raw, _, rfl⟩ := map_nonzero_source' _ _ _ hmiddle
+        intro hpost
+        change (certificateMonitorUpdate (monitorKey parameter root) budget required (proposalStop stopAfter) (.inr message)
+          (monitorView state.2) annotation.1
+          (proposalOfSigningRecord message raw.1 raw.2.1 (raw.1.1.2.elim annotation.2 Prod.fst))).stopped = false at hpost
+        simp only [certificateMonitorUpdate, if_neg hactive, Bool.true_eq_false] at hpost
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessProposalPayment.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessProposalPayment.lean
new file mode 100644
index 000000000..d4a9f4039
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessProposalPayment.lean
@@ -0,0 +1,263 @@
+import SphincsSecurity.Proof.Forced.FtsGuessProposalInvariant
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec UniformTableCompletion OtsContactTrace ENNReal
+open FtsGuessSigning (Coordinate)
+open FtsProbeSimulation (MessageHashInput messageAnswers)
+open SecretGuessObservation (State)
+open RetainedResidual (proposalStop)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  publicDigestLoop canonicalGraphRoot canonicalGraphInput hashInputs UniformTableCompletion.complete signDigestLoop
+
+variable (parameter : PublicParameter) (root : Digest)
+  (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+  (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+  (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (dummy : OtsReferenceWords) (slot : Nat)
+  (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+/-! ### Creation counters along proposal steps -/
+
+theorem proposalStep_creation_counters (input : (OracleWorld + SigningSpec).Domain) (state : ProposalState)
+    (result : AdversaryStep input × ProposalState)
+    (hresult : proposalStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      input state result ≠ 0) :
+    result.2.2.2.creationCost = state.2.2.creationCost +
+        certificateMonitorCharge (monitorKey parameter root) budget required input (monitorView state.2) ∧
+      result.2.2.2.creationMass = state.2.2.creationMass +
+        certificateMonitorMass (monitorKey parameter root) budget input (monitorView state.2) :=
+  monitoredStep_creation_counters parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input
+    state.2 _ (proposalStep_forced parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input
+      state result hresult)
+
+theorem proposalStep_bind_const {Other : Type} (input : (OracleWorld + SigningSpec).Domain) (state : ProposalState) (hvalid : Valid state.2)
+    (after : SPMF Other) :
+    (proposalStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state >>=
+      fun _ => after) = after := by
+  have h := monitoredStep_bind_const parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input
+    state.2 hvalid after
+  rw [← proposalStep_erasure parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state,
+    bind_map_left] at h
+  exact h
+
+theorem tsum_proposalStep_eq_one (input : (OracleWorld + SigningSpec).Domain) (state : ProposalState) (hvalid : Valid state.2) :
+    (∑' result, Pr[= result | proposalStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      input state]) = 1 := by
+  have h := congrArg (fun law : SPMF Unit => Pr[= () | law])
+    (proposalStep_bind_const parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state
+      hvalid (pure ()))
+  simpa only [probOutput_bind_eq_tsum, probOutput_pure_self, mul_one] using h
+
+theorem expected_proposalStep_creationCost (input : (OracleWorld + SigningSpec).Domain) (state : ProposalState) (hvalid : Valid state.2) :
+    (∑' result, Pr[= result | proposalStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        input state] * result.2.2.2.creationCost) =
+      state.2.2.creationCost + certificateMonitorCharge (monitorKey parameter root) budget required input (monitorView state.2) := by
+  calc
+    _ = ∑' result, Pr[= result | proposalStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          input state] *
+        (state.2.2.creationCost + certificateMonitorCharge (monitorKey parameter root) budget required input (monitorView state.2)) := by
+      apply tsum_congr
+      intro result
+      by_cases hr : Pr[= result | proposalStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter input state] = 0
+      · simp only [hr, zero_mul]
+      · rw [SPMF.probOutput_eq_apply] at hr
+        rw [(proposalStep_creation_counters parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          input state result hr).1]
+    _ = _ := by
+      rw [ENNReal.tsum_mul_right, tsum_proposalStep_eq_one parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+        required stopAfter input state hvalid, one_mul]
+
+theorem expected_proposalStep_mass_terminalPotential (total : Nat) (payoff : List Index → ENNReal)
+    (input : (OracleWorld + SigningSpec).Domain) (state : ProposalState) (hvalid : Valid state.2)
+    (hinputs : ∀ message, input = .inr message → hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs) :
+    (∑' result, Pr[= result | proposalStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        input state] * (result.2.2.2.creationMass * terminalProposalPotential (PMF.uniformOfFintype Index) total payoff result.2.1)) =
+      state.2.2.creationMass * terminalProposalPotential (PMF.uniformOfFintype Index) total payoff state.1 +
+        certificateMonitorMass (monitorKey parameter root) budget input (monitorView state.2) *
+          terminalProposalPotential (PMF.uniformOfFintype Index) total payoff state.1 := by
+  calc
+    _ = ∑' result, Pr[= result | proposalStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          input state] *
+        ((state.2.2.creationMass + certificateMonitorMass (monitorKey parameter root) budget input (monitorView state.2)) *
+          terminalProposalPotential (PMF.uniformOfFintype Index) total payoff result.2.1) := by
+      apply tsum_congr
+      intro result
+      by_cases hr : Pr[= result | proposalStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter input state] = 0
+      · simp only [hr, zero_mul]
+      · rw [SPMF.probOutput_eq_apply] at hr
+        rw [(proposalStep_creation_counters parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          input state result hr).2]
+    _ = (state.2.2.creationMass + certificateMonitorMass (monitorKey parameter root) budget input (monitorView state.2)) *
+        ∑' result, Pr[= result | proposalStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          input state] * terminalProposalPotential (PMF.uniformOfFintype Index) total payoff result.2.1 := by
+      simp_rw [mul_left_comm _ (state.2.2.creationMass + certificateMonitorMass (monitorKey parameter root) budget input (monitorView state.2))]
+      exact ENNReal.tsum_mul_left
+    _ = _ := by
+      rw [expected_proposalStep_terminalPotential parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter input state hvalid hinputs total payoff]
+      exact add_mul _ _ _
+
+/-! ### Payment accumulators along proposal runs -/
+
+variable (hauxiliary : ∀ seed : inputs → HashOutput,
+  (⟨selections, rows, seed⟩ : ReferenceAuxiliary inputs) ∈ (referenceAuxiliarySample inputs).support)
+
+noncomputable def expectedProposalPayment (charge : (OracleWorld + SigningSpec).Domain → ProposalState → ENNReal)
+    (computation : OracleComp (OracleWorld + SigningSpec) Forgery) : ProposalState → ENNReal :=
+  OracleComp.construct (fun _ _ => 0) (fun input _ next state => charge input state +
+    ∑' result, Pr[= result | proposalStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      input state] * next result.1.1.1 result.2) computation
+
+theorem expectedProposalPayment_query_bind (charge : (OracleWorld + SigningSpec).Domain → ProposalState → ENNReal)
+    (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Forgery) (state : ProposalState) :
+    expectedProposalPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter charge
+      (liftM ((OracleWorld + SigningSpec).query input) >>= next) state =
+      charge input state +
+        ∑' result, Pr[= result | proposalStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          stopAfter input state] *
+          expectedProposalPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter charge
+            (next result.1.1.1) result.2 := rfl
+
+include hauxiliary in
+theorem expected_proposalRun_accumulator (counter : ProposalState → ENNReal)
+    (charge : (OracleWorld + SigningSpec).Domain → ProposalState → ENNReal)
+    (hstep : ∀ input state, Valid state.2 →
+      (∀ message, input = .inr message → hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs) →
+      (∑' result, Pr[= result | proposalStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter input state] * counter result.2) = counter state + charge input state)
+    (computation : OracleComp (OracleWorld + SigningSpec) Forgery) (state : ProposalState) (hvalid : Valid state.2)
+    (hcovered : CoveredRun parameter root otsSecret inputs computation state.2) :
+    (∑' result, Pr[= result | proposalRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        computation state] * counter result.2) =
+      counter state +
+        expectedProposalPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter charge
+          computation state := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [proposalRun_pure, tsum_probOutput_pure_mul, expectedProposalPayment, construct_pure, add_zero]
+  | query_bind input next ih =>
+      rw [proposalRun_query_bind, tsum_probOutput_bind_mul, expectedProposalPayment_query_bind]
+      calc
+        _ = ∑' result, Pr[= result | proposalStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+              stopAfter input state] *
+            (counter result.2 +
+              expectedProposalPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+                charge (next result.1.1.1) result.2) := by
+          apply tsum_congr
+          intro result
+          by_cases hr : Pr[= result | proposalStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+              stopAfter input state] = 0
+          · simp only [hr, zero_mul]
+          · rw [SPMF.probOutput_eq_apply] at hr
+            rw [tsum_probOutput_map_mul]
+            apply congrArg (_ * ·)
+            exact ih result.1.1.1 result.2
+              (proposalStep_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input
+                state hvalid result hr)
+              (covered_step_next parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter hauxiliary
+                input next state.2 hvalid hcovered (result.1, result.2.2)
+                (proposalStep_forced parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input
+                  state result hr))
+        _ = _ := by
+          simp only [mul_add, ENNReal.tsum_add]
+          rw [hstep input state hvalid (covered_step_digest parameter root otsSecret inputs input next state.2 hvalid hcovered), add_assoc]
+
+/-! ### Invariants along proposal runs -/
+
+include hauxiliary in
+theorem proposalRun_invariant (total : Nat) (computation : OracleComp (OracleWorld + SigningSpec) Forgery) (state : ProposalState)
+    (hvalid : Valid state.2) (hcovered : CoveredRun parameter root otsSecret inputs computation state.2)
+    (hinv : ProposalInvariant parameter root total state) (result : AdversaryTrace × ProposalState)
+    (hresult : proposalRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required (proposalStop stopAfter)
+      computation state result ≠ 0) :
+    ProposalInvariant parameter root total result.2 := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      rw [proposalRun_pure] at hresult
+      simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact hinv
+  | query_bind input next ih =>
+      rw [proposalRun_query_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨step, hstep, hresult⟩ := hresult
+      obtain ⟨tail, htail, rfl⟩ := map_nonzero_source' _ _ _ hresult
+      have hforced := proposalStep_forced parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        (proposalStop stopAfter) input state step hstep
+      exact ih step.1.1.1 step.2
+        (proposalStep_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required (proposalStop stopAfter)
+          input state hvalid step hstep)
+        (covered_step_next parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required (proposalStop stopAfter)
+          hauxiliary input next state.2 hvalid hcovered (step.1, step.2.2) hforced)
+        (proposalStep_invariant parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter total input
+          state hvalid
+          (fun world heq => by subst heq; exact covered_world_inputs parameter root otsSecret inputs world next state.2 hvalid hcovered)
+          (covered_step_digest parameter root otsSecret inputs input next state.2 hvalid hcovered) hinv step hstep) tail htail
+
+include hauxiliary in
+theorem expectedProposalPayment_charge_le_mass_terminalPotential (total : Nat)
+    (computation : OracleComp (OracleWorld + SigningSpec) Forgery) (state : ProposalState) (hvalid : Valid state.2)
+    (hcovered : CoveredRun parameter root otsSecret inputs computation state.2) (hbudget : budget ≤ 2 ^ 127)
+    (hinv : ProposalInvariant parameter root total state) :
+    expectedProposalPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required (proposalStop stopAfter)
+      (fun input current => certificateMonitorCharge (monitorKey parameter root) budget required input (monitorView current.2)) computation state ≤
+      expectedProposalPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required (proposalStop stopAfter)
+        (fun input current => certificateMonitorMass (monitorKey parameter root) budget input (monitorView current.2) *
+          terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice required) current.1) computation state := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => exact le_rfl
+  | query_bind input next ih =>
+      rw [expectedProposalPayment_query_bind, expectedProposalPayment_query_bind]
+      apply add_le_add (certificateMonitorCharge_le_terminalPrice_of_invariant (monitorKey parameter root) budget total required input
+        (state.1, monitorView state.2) hbudget hinv)
+      apply ENNReal.tsum_le_tsum
+      intro result
+      by_cases hr : Pr[= result | proposalStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          (proposalStop stopAfter) input state] = 0
+      · simp only [hr, zero_mul, le_refl]
+      · rw [SPMF.probOutput_eq_apply] at hr
+        have hforced := proposalStep_forced parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+          (proposalStop stopAfter) input state result hr
+        apply mul_le_mul' le_rfl
+        exact ih result.1.1.1 result.2
+          (proposalStep_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required (proposalStop stopAfter)
+            input state hvalid result hr)
+          (covered_step_next parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required (proposalStop stopAfter)
+            hauxiliary input next state.2 hvalid hcovered (result.1, result.2.2) hforced)
+          (proposalStep_invariant parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter total
+            input state hvalid
+            (fun world heq => by subst heq; exact covered_world_inputs parameter root otsSecret inputs world next state.2 hvalid hcovered)
+            (covered_step_digest parameter root otsSecret inputs input next state.2 hvalid hcovered) hinv result hr)
+
+include hauxiliary in
+theorem expected_proposalRun_mass_terminalPotential (total : Nat) (computation : OracleComp (OracleWorld + SigningSpec) Forgery)
+    (state : ProposalState) (hvalid : Valid state.2) (hcovered : CoveredRun parameter root otsSecret inputs computation state.2) :
+    (∑' result, Pr[= result | proposalRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        computation state] *
+      (result.2.2.2.creationMass * terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice required) result.2.1)) =
+      state.2.2.creationMass * terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice required) state.1 +
+        expectedProposalPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          (fun input current => certificateMonitorMass (monitorKey parameter root) budget input (monitorView current.2) *
+            terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice required) current.1) computation state :=
+  expected_proposalRun_accumulator parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter hauxiliary
+    (fun state => state.2.2.creationMass * terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice required) state.1)
+    _ (fun input state hvalid hinputs => expected_proposalStep_mass_terminalPotential parameter root otsSecret labels inputs hencoding selections
+      rows dummy slot budget required stopAfter total (terminalCertificatePrice required) input state hvalid hinputs) computation state hvalid hcovered
+
+include hauxiliary in
+theorem expected_proposalRun_creationCost (computation : OracleComp (OracleWorld + SigningSpec) Forgery) (state : ProposalState)
+    (hvalid : Valid state.2) (hcovered : CoveredRun parameter root otsSecret inputs computation state.2) :
+    (∑' result, Pr[= result | proposalRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        computation state] * result.2.2.2.creationCost) =
+      state.2.2.creationCost +
+        expectedProposalPayment parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          (fun input current => certificateMonitorCharge (monitorKey parameter root) budget required input (monitorView current.2))
+          computation state :=
+  expected_proposalRun_accumulator parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter hauxiliary
+    (fun state => state.2.2.creationCost) _
+    (fun input state hvalid _ => expected_proposalStep_creationCost parameter root otsSecret labels inputs hencoding selections rows dummy slot
+      budget required stopAfter input state hvalid) computation state hvalid hcovered
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessProposalStep.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessProposalStep.lean
new file mode 100644
index 000000000..95b5f7067
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessProposalStep.lean
@@ -0,0 +1,413 @@
+import SphincsSecurity.Proof.Forced.FtsGuessMonitoredPayment
+import SphincsSecurity.Proof.Residual.RetainedResidualProposalSupport
+import SphincsSecurity.Proof.Residual.RetainedResidualProposalWord
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec UniformTableCompletion OtsContactTrace ENNReal
+open FtsGuessSigning (Coordinate)
+open FtsProbeSimulation (MessageHashInput messageAnswers)
+open SecretGuessObservation (State)
+open RetainedResidual (proposalOfSigningRecord proposalOfWorldResult signingAnnotation completeRecordIndex attachRejectedWord
+  digestCompletionValue pmfLift_bind pmfLift_map)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  publicDigestLoop canonicalGraphRoot canonicalGraphInput hashInputs UniformTableCompletion.complete signDigestLoop
+
+variable (parameter : PublicParameter) (root : Digest)
+  (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+  (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+  (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (dummy : OtsReferenceWords) (slot : Nat)
+  (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+theorem bind_const_of_eq {A B : Type} (law : SPMF A) (next : A → SPMF B) (after : SPMF B) (hnext : ∀ value, next value = after)
+    (hconst : (law >>= fun _ => after) = after) : (law >>= next) = after := by
+  rw [show next = fun _ => after from funext hnext]
+  exact hconst
+
+/-! ### The forced signing law and its digest record -/
+
+theorem publicSigningWork_bank_digest' (key : SecretKey) (hparameter : key.parameter = parameter) (hroot : key.root = root)
+    (known : CanonicalProbeRouting.Labels) (words : OtsReferenceWords) (selections : ReferenceFamily)
+    (actual : CanonicalProbeRouting.Labels) (message : Message) (cache : QueryCache HashSpec) :
+    (fun result => ((completePublicSigningRecord (fun index tree leaf => actual (.ftsStart index tree leaf)) result.1).1, result.2)) <$>
+      𝒟[(simulateQ romImpl (Prod.fst <$> ResidualByteFrontend.publicSigningWork parameter root known words selections message)).run cache] =
+        digestCompletionValue known words selections actual <$>
+          𝒟[(simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run cache] := by
+  subst hparameter hroot
+  exact publicSigningWork_bank_digest key known words selections actual message cache
+
+noncomputable def forcedSigning (message : Message) (state : MonitoredState) :
+    SPMF (((Option Signature × Option FewTimeView) × SigningBoundaryTrace) × CachedState) :=
+  cachedForcedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot (signingProgram message) state.1
+
+def forcedSigningView (result : ((Option Signature × Option FewTimeView) × SigningBoundaryTrace) × CachedState) : Option FewTimeView :=
+  result.1.1.2
+
+theorem forcedSigning_digestRecord (message : Message) (state : MonitoredState) (hvalid : Valid state)
+    (hinputs : hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs)
+    (result : ((Option Signature × Option FewTimeView) × SigningBoundaryTrace) × CachedState)
+    (hresult : forcedSigning parameter root otsSecret labels inputs hencoding selections rows dummy slot message state result ≠ 0) :
+    ∃ loop, loop ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit (monitorKey parameter root) message)).run state.1.1) ∧
+      result.2.1 = loop.2 ∧ DigestCompletionPreservesMessages (monitorKey parameter root) loop (result.1.1, result.2.1) := by
+  rw [forcedSigning, cachedForcedRun_signingProgram' parameter root otsSecret labels inputs hencoding selections rows dummy slot message state.1
+    hvalid hinputs (referenceAnswers parameter root otsSecret labels inputs hencoding ⟨selections, rows, fun _ => 0⟩ dummy),
+    RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨secrets, _, hresult⟩ := hresult
+  obtain ⟨raw, hraw, rfl⟩ := map_nonzero_source' _ _ _ hresult
+  have h := map_nonzero_of _ (fun result => ((completePublicSigningRecord
+    (fun index tree leaf => secretLabels secrets (.ftsStart index tree leaf)) result.1).1, result.2)) raw hraw
+  rw [publicSigningWork_bank_digest' parameter root (monitorKey parameter root) rfl rfl (known otsSecret labels)
+    (referenceFamilyWords selections dummy) selections (secretLabels secrets) message state.1.1] at h
+  obtain ⟨loop, hloop, heq⟩ := map_nonzero_source' _ _ _ h
+  refine ⟨loop, (mem_support_iff_evalDist_apply_ne_zero _ _).mpr hloop, ?_, ?_⟩
+  · exact congrArg Prod.snd heq
+  · have hvalue : ((completePublicSigningRecord (fun index tree leaf => secrets (index, tree, leaf)) raw.1).1, raw.2) =
+        digestCompletionValue (known otsSecret labels) (referenceFamilyWords selections dummy) selections (secretLabels secrets) loop := heq
+    rw [hvalue]
+    exact RetainedResidual.digestCompletionValue_preservesMessages (monitorKey parameter root) _ _ _ _ loop
+
+theorem forcedSigning_selectedView (message : Message) (state : MonitoredState) (hvalid : Valid state)
+    (hinputs : hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs) :
+    forcedSigningView <$> forcedSigning parameter root otsSecret labels inputs hencoding selections rows dummy slot message state =
+      selectedLoopView? <$>
+        𝒟[(simulateQ romImpl (signDigestLoop digestAttemptLimit (monitorKey parameter root) message)).run (monitorView state).1] := by
+  rw [forcedSigning, cachedForcedRun_signingProgram' parameter root otsSecret labels inputs hencoding selections rows dummy slot message state.1
+    hvalid hinputs (referenceAnswers parameter root otsSecret labels inputs hencoding ⟨selections, rows, fun _ => 0⟩ dummy), map_bind]
+  simp only [Functor.map_map]
+  calc
+    _ = complete state.1.2.allowed >>= fun _ => selectedLoopView? <$>
+        𝒟[(simulateQ romImpl (signDigestLoop digestAttemptLimit (monitorKey parameter root) message)).run state.1.1] := by
+      apply congrArg (complete state.1.2.allowed >>= ·)
+      funext secrets
+      have h := congrArg (Functor.map (fun value : (Option Signature × Option FewTimeView) × QueryCache HashSpec => value.1.2))
+        (publicSigningWork_bank_digest' parameter root (monitorKey parameter root) rfl rfl (known otsSecret labels)
+          (referenceFamilyWords selections dummy) selections (secretLabels secrets) message state.1.1)
+      simp only [Functor.map_map] at h
+      rw [show (fun result : (PublicSigningRecord × QueryCache HashSpec) =>
+          forcedSigningView (completePublicSigningRecord (fun index tree leaf => secrets (index, tree, leaf)) result.1,
+            (result.2, FtsGuessSigning.completedState
+              (SecretGuessObservation.environment (referenceAnswers parameter root otsSecret labels inputs hencoding
+                ⟨selections, rows, fun _ => 0⟩ dummy)) secrets result.1 state.1.2))) =
+          fun result => ((completePublicSigningRecord (fun index tree leaf => secretLabels secrets (.ftsStart index tree leaf)) result.1).1,
+            result.2).1.2 from rfl, h]
+      congr 1
+      funext loop
+      exact (RetainedResidual.digestCompletionValue_preservesMessages (monitorKey parameter root) _ _ _ _ loop).1.1
+    _ = _ := by
+      rw [complete_of_nonempty _ hvalid, RetainedObservation.lift_bind_const, monitorView_fst]
+
+/-! ### Completing the proposal index -/
+
+noncomputable def completedForcedSigning (message : Message) (state : MonitoredState) :
+    SPMF ((((Option Signature × Option FewTimeView) × SigningBoundaryTrace) × CachedState) × Index) :=
+  completeRecordIndex (forcedSigning parameter root otsSecret labels inputs hencoding selections rows dummy slot message state) forcedSigningView
+
+theorem completedForcedSigning_record (message : Message) (state : MonitoredState) :
+    Prod.fst <$> completedForcedSigning parameter root otsSecret labels inputs hencoding selections rows dummy slot message state =
+      forcedSigning parameter root otsSecret labels inputs hencoding selections rows dummy slot message state :=
+  RetainedResidual.completeRecordIndex_record _ _
+
+theorem completedForcedSigning_index (message : Message) (state : MonitoredState) (hvalid : Valid state)
+    (hinputs : hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs) :
+    Prod.snd <$> completedForcedSigning parameter root otsSecret labels inputs hencoding selections rows dummy slot message state =
+      (liftM ((originalProposalRecord (monitorKey parameter root) (.inr message) (monitorView state).1).map (fun record => record.index)) :
+        SPMF Index) := by
+  rw [completedForcedSigning, RetainedResidual.completeRecordIndex_index,
+    forcedSigning_selectedView parameter root otsSecret labels inputs hencoding selections rows dummy slot message state hvalid hinputs,
+    RetainedResidual.originalProposalRecord_index_loop]
+
+/-! ### Proposal steps -/
+
+noncomputable def signResult (message : Message) (annotation : Nat × Index) (state : MonitoredState)
+    (result : ((Option Signature × Option FewTimeView) × SigningBoundaryTrace) × CachedState) :
+    AdversaryStep (.inr message) × MonitoredState :=
+  (((result.1.1.1, result.1.2), 1),
+    (result.2, certificateMonitorUpdate (monitorKey parameter root) budget required stopAfter (.inr message) (monitorView state) annotation.1
+      (proposalOfSigningRecord message result.1 result.2.1 (result.1.1.2.elim annotation.2 Prod.fst))))
+
+theorem monitoredSignStep_eq (message : Message) (state : MonitoredState) :
+    monitoredSignStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter message state =
+      ((liftM (signingAnnotation (monitorKey parameter root) budget message (monitorView state)) : SPMF _) >>= fun annotation =>
+        signResult parameter root budget required stopAfter message annotation state <$>
+          forcedSigning parameter root otsSecret labels inputs hencoding selections rows dummy slot message state) := rfl
+
+theorem signResult_completed (message : Message) (length : Nat) (fallback : Index) (state : MonitoredState)
+    (result : ((Option Signature × Option FewTimeView) × SigningBoundaryTrace) × CachedState) :
+    signResult parameter root budget required stopAfter message (length, (forcedSigningView result).elim fallback Prod.fst) state result =
+      signResult parameter root budget required stopAfter message (length, fallback) state result := by
+  rcases result with ⟨⟨⟨signature, view⟩, trace⟩, cached⟩
+  cases view <;> rfl
+
+theorem completedForcedSigning_monitored (message : Message) (length : Nat) (state : MonitoredState) :
+    (fun result => signResult parameter root budget required stopAfter message (length, result.2) state result.1) <$>
+        completedForcedSigning parameter root otsSecret labels inputs hencoding selections rows dummy slot message state =
+      ((liftM (PMF.uniformOfFintype Index) : SPMF Index) >>= fun fallback =>
+        signResult parameter root budget required stopAfter message (length, fallback) state <$>
+          forcedSigning parameter root otsSecret labels inputs hencoding selections rows dummy slot message state) := by
+  rw [completedForcedSigning, RetainedResidual.completeRecordIndex_fallback, map_bind]
+  simp only [Functor.map_map, signResult_completed]
+
+abbrev ProposalState := List Index × MonitoredState
+
+noncomputable def proposalStep : (input : (OracleWorld + SigningSpec).Domain) → ProposalState → SPMF (AdversaryStep input × ProposalState)
+  | .inl input, state =>
+      (fun result => (result.1, (state.1, result.2))) <$>
+        monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter (.inl input) state.2
+  | .inr message, state =>
+      if CertificateMonitorActive (monitorKey parameter root) budget (.inr message) (monitorView state.2) then
+        (fun result =>
+          let after := signResult parameter root budget required stopAfter message (result.1.length + 1, result.2.2) state.2 result.2.1
+          (after.1, (state.1 ++ (result.1 ++ [result.2.2]), after.2))) <$>
+          attachRejectedWord (completedForcedSigning parameter root otsSecret labels inputs hencoding selections rows dummy slot message state.2)
+            (originalRejectedProposal (monitorKey parameter root) (fun current => current.2.spent) (.inr message) (monitorView state.2))
+      else
+        (fun result => (result.1, (state.1, result.2))) <$>
+          monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter (.inr message) state.2
+
+theorem proposalStep_erasure (input : (OracleWorld + SigningSpec).Domain) (state : ProposalState) :
+    Prod.map id Prod.snd <$> proposalStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        input state =
+      monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state.2 := by
+  cases input with
+  | inl input =>
+      rw [proposalStep, Functor.map_map]
+      exact id_map' _
+  | inr message =>
+      rw [proposalStep]
+      split_ifs with hactive
+      · rw [Functor.map_map]
+        calc
+          _ = (fun result => signResult parameter root budget required stopAfter message (result.1, result.2.2) state.2 result.2.1) <$>
+              ((fun result => (result.1.length + 1, result.2)) <$>
+                attachRejectedWord
+                  (completedForcedSigning parameter root otsSecret labels inputs hencoding selections rows dummy slot message state.2)
+                  (originalRejectedProposal (monitorKey parameter root) (fun current => current.2.spent) (.inr message) (monitorView state.2))) := by
+            rw [Functor.map_map]
+            rfl
+          _ = _ := by
+            rw [RetainedResidual.attachRejectedWord_length, map_bind, monitoredStep, monitoredSignStep_eq, signingAnnotation, if_pos hactive,
+              pmfLift_bind]
+            simp only [Functor.map_map, pmfLift_map, bind_assoc, bind_map_left]
+            simp_rw [completedForcedSigning_monitored]
+      · rw [Functor.map_map]
+        exact id_map' _
+
+theorem proposalStep_forced (input : (OracleWorld + SigningSpec).Domain) (state : ProposalState)
+    (result : AdversaryStep input × ProposalState)
+    (hresult : proposalStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      input state result ≠ 0) :
+    monitoredStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state.2
+      (result.1, result.2.2) ≠ 0 := by
+  have h := map_nonzero_of _ (Prod.map id Prod.snd) result hresult
+  rwa [proposalStep_erasure] at h
+
+theorem proposalStep_valid (input : (OracleWorld + SigningSpec).Domain) (state : ProposalState) (hvalid : Valid state.2)
+    (result : AdversaryStep input × ProposalState)
+    (hresult : proposalStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      input state result ≠ 0) : Valid result.2.2 :=
+  monitoredStep_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state.2 hvalid
+    _ (proposalStep_forced parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state
+      result hresult)
+
+theorem proposalStep_complete (input : (OracleWorld + SigningSpec).Domain) (state : ProposalState) (hvalid : Valid state.2)
+    (hinputs : ∀ message, input = .inr message → hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs)
+    (total : Nat) :
+    (proposalStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state >>=
+      fun result => (liftM (completeProposalWord (PMF.uniformOfFintype Index) total result.2.1) : SPMF (List Index))) =
+      (liftM (completeProposalWord (PMF.uniformOfFintype Index) total state.1) : SPMF (List Index)) := by
+  cases input with
+  | inl input =>
+      rw [proposalStep, bind_map_left]
+      exact bind_const_of_eq _ _ _ (fun _ => rfl)
+        (monitoredStep_bind_const parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          (.inl input) state.2 hvalid _)
+  | inr message =>
+      rw [proposalStep]
+      split_ifs with hactive
+      · rw [bind_map_left]
+        have hbound : ProposalCacheBound (monitorKey parameter root) (monitorView state.2).1 (monitorView state.2).2.spent := hactive.2.1.2.1
+        rw [originalRejectedProposal, dif_pos hbound]
+        exact RetainedResidual.attachRejectedWord_complete _ Prod.snd
+          (originalProposalRecord (monitorKey parameter root) (.inr message) (monitorView state.2).1) (fun record => record.index)
+          (completedForcedSigning_index parameter root otsSecret labels inputs hencoding selections rows dummy slot message state.2 hvalid
+            (hinputs message rfl))
+          (originalProposalRecord_cap (monitorKey parameter root) message (monitorView state.2).1 (monitorView state.2).2.spent hbound) total state.1
+      · rw [bind_map_left]
+        exact bind_const_of_eq _ _ _ (fun _ => rfl)
+          (monitoredStep_bind_const parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+            (.inr message) state.2 hvalid _)
+
+theorem expected_proposalStep_terminalPotential (input : (OracleWorld + SigningSpec).Domain) (state : ProposalState) (hvalid : Valid state.2)
+    (hinputs : ∀ message, input = .inr message → hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs)
+    (total : Nat) (payoff : List Index → ENNReal) :
+    (∑' result, Pr[= result | proposalStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        input state] * terminalProposalPotential (PMF.uniformOfFintype Index) total payoff result.2.1) =
+      terminalProposalPotential (PMF.uniformOfFintype Index) total payoff state.1 := by
+  have h := congrArg (fun law : SPMF (List Index) => ∑' word, Pr[= word | law] * payoff word)
+    (proposalStep_complete parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state
+      hvalid hinputs total)
+  rw [tsum_probOutput_bind_mul] at h
+  simpa only [terminalProposalPotential, SPMF.probOutput_liftM] using h
+
+/-! ### Proposal runs -/
+
+noncomputable def proposalRun {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result) :
+    ProposalState → SPMF ((((Result × QueryLog SigningSpec) × SigningBoundaryTrace) × Trace) × ProposalState) :=
+  OracleComp.construct (fun value state => pure ((((value, []), 1), 1), state))
+    (fun input _ next state =>
+      proposalStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state >>= fun step =>
+        (fun tail => (combineStep input step.1 tail.1, tail.2)) <$> next step.1.1.1 step.2) computation
+
+theorem proposalRun_pure {Result : Type} (value : Result) (state : ProposalState) :
+    proposalRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter (pure value) state =
+      pure ((((value, []), 1), 1), state) := rfl
+
+theorem proposalRun_query_bind {Result : Type} (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Result) (state : ProposalState) :
+    proposalRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      (liftM ((OracleWorld + SigningSpec).query input) >>= next) state =
+      (proposalStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state >>= fun step =>
+        (fun tail => (combineStep input step.1 tail.1, tail.2)) <$>
+          proposalRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+            (next step.1.1.1) step.2) := by
+  rw [proposalRun, OracleComp.construct_query_bind]
+  rfl
+
+theorem proposalRun_erasure {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result) (state : ProposalState) :
+    Prod.map id Prod.snd <$>
+        proposalRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter computation state =
+      monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter computation state.2 := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => rw [proposalRun_pure, monitoredRun_pure, map_pure]; rfl
+  | query_bind input next ih =>
+      rw [proposalRun_query_bind, map_bind, monitoredRun_query_bind,
+        ← proposalStep_erasure parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state,
+        bind_map_left]
+      apply congrArg (_ >>= ·)
+      funext step
+      simp only [Prod.map_fst, Prod.map_snd, id_eq]
+      rw [Functor.map_map, ← ih step.1.1.1 step.2, Functor.map_map]
+      rfl
+
+theorem proposalRun_forced {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result) (state : ProposalState)
+    (result : (((Result × QueryLog SigningSpec) × SigningBoundaryTrace) × Trace) × ProposalState)
+    (hresult : proposalRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      computation state result ≠ 0) :
+    monitoredRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter computation state.2
+      (result.1, result.2.2) ≠ 0 := by
+  have h := map_nonzero_of _ (Prod.map id Prod.snd) result hresult
+  rwa [proposalRun_erasure] at h
+
+/-! ### Coverage along proposal runs -/
+
+theorem covered_step_digest (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Forgery)
+    (state : MonitoredState) (hvalid : Valid state)
+    (hcovered : CoveredRun parameter root otsSecret inputs (liftM ((OracleWorld + SigningSpec).query input) >>= next) state) :
+    ∀ message, input = .inr message → hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs := by
+  intro message heq
+  subst heq
+  exact covered_sign_digest parameter root otsSecret inputs message next state hvalid hcovered
+
+variable (hauxiliary : ∀ seed : inputs → HashOutput,
+  (⟨selections, rows, seed⟩ : ReferenceAuxiliary inputs) ∈ (referenceAuxiliarySample inputs).support)
+
+include hauxiliary in
+theorem proposalRun_complete (computation : OracleComp (OracleWorld + SigningSpec) Forgery) (state : ProposalState) (hvalid : Valid state.2)
+    (hcovered : CoveredRun parameter root otsSecret inputs computation state.2) (total : Nat) :
+    (proposalRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter computation state >>=
+      fun result => (liftM (completeProposalWord (PMF.uniformOfFintype Index) total result.2.1) : SPMF (List Index))) =
+      (liftM (completeProposalWord (PMF.uniformOfFintype Index) total state.1) : SPMF (List Index)) := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => rw [proposalRun_pure, pure_bind]
+  | query_bind input next ih =>
+      rw [proposalRun_query_bind, bind_assoc]
+      calc
+        _ = proposalStep parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input state >>=
+            fun result => (liftM (completeProposalWord (PMF.uniformOfFintype Index) total result.2.1) : SPMF (List Index)) := by
+          apply RetainedObservation.bind_congr
+          intro result hresult
+          rw [bind_map_left]
+          have hforced := proposalStep_forced parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+            stopAfter input state result hresult
+          exact ih result.1.1.1 result.2
+            (proposalStep_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter input
+              state hvalid result hresult)
+            (covered_step_next parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter hauxiliary
+              input next state.2 hvalid hcovered (result.1, result.2.2) hforced)
+        _ = _ := proposalStep_complete parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          input state hvalid (covered_step_digest parameter root otsSecret inputs input next state.2 hvalid hcovered) total
+
+/-! ### The completed proposal run -/
+
+theorem monitoredWorldRun_bind_const {Result Other : Type} (computation : OracleComp OracleWorld Result) (state : MonitoredState)
+    (hvalid : Valid state) (after : SPMF Other) :
+    (monitoredWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter computation state >>=
+      fun _ => after) = after := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => rw [monitoredWorldRun_pure, pure_bind]
+  | query_bind input next ih =>
+      rw [monitoredWorldRun_query_bind, bind_assoc]
+      rw [RetainedObservation.bind_congr _ _ (fun _ => after) (fun step hstep => by
+        rw [bind_map_left]
+        exact ih step.1.1.1 step.2 (monitoredStep_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget
+          required stopAfter (.inl input) state hvalid step hstep))]
+      exact monitoredWorldStep_bind_const parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        input state hvalid after
+
+noncomputable def proposalCompletedRun (adversary : Adversary) (state : ProposalState) : SPMF (Completed × ProposalState) :=
+  proposalRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+    (adversary.main ⟨root, parameter⟩) state >>= fun before =>
+    (fun checked => ((before.1, checked.1), (before.2.1, checked.2))) <$>
+      monitoredWorldRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        (verifyComputation parameter root before.1.1.1.1) before.2.2
+
+theorem proposalCompletedRun_erasure (adversary : Adversary) (state : ProposalState) :
+    Prod.map id Prod.snd <$>
+        proposalCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter adversary state =
+      monitoredCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter adversary
+        state.2 := by
+  rw [proposalCompletedRun, monitoredCompletedRun_eq, map_bind, ← proposalRun_erasure, bind_map_left]
+  apply congrArg (_ >>= ·)
+  funext before
+  rw [Functor.map_map]
+  rfl
+
+include hauxiliary in
+theorem proposalCompletedRun_complete (adversary : Adversary) (state : ProposalState) (hvalid : Valid state.2)
+    (hcovered : CoveredRun parameter root otsSecret inputs (adversary.main ⟨root, parameter⟩) state.2) (total : Nat) :
+    (proposalCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter adversary state >>=
+      fun result => (liftM (completeProposalWord (PMF.uniformOfFintype Index) total result.2.1) : SPMF (List Index))) =
+      (liftM (completeProposalWord (PMF.uniformOfFintype Index) total state.1) : SPMF (List Index)) := by
+  rw [proposalCompletedRun, bind_assoc]
+  calc
+    _ = proposalRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        (adversary.main ⟨root, parameter⟩) state >>= fun before =>
+          (liftM (completeProposalWord (PMF.uniformOfFintype Index) total before.2.1) : SPMF (List Index)) := by
+      apply RetainedObservation.bind_congr
+      intro before hbefore
+      rw [bind_map_left]
+      have hforced := proposalRun_forced parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+        (adversary.main ⟨root, parameter⟩) state before hbefore
+      exact bind_const_of_eq _ _ _ (fun _ => rfl)
+        (monitoredWorldRun_bind_const parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+          _ before.2.2 (monitoredRun_valid parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+            (adversary.main ⟨root, parameter⟩) state.2 hvalid _ hforced) _)
+    _ = _ := proposalRun_complete parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter hauxiliary
+      (adversary.main ⟨root, parameter⟩) state hvalid hcovered total
+
+include hauxiliary in
+theorem expected_proposalCompletedRun_terminalPotential (adversary : Adversary) (state : ProposalState) (hvalid : Valid state.2)
+    (hcovered : CoveredRun parameter root otsSecret inputs (adversary.main ⟨root, parameter⟩) state.2) (total : Nat)
+    (payoff : List Index → ENNReal) :
+    (∑' result, Pr[= result | proposalCompletedRun parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required
+        stopAfter adversary state] * terminalProposalPotential (PMF.uniformOfFintype Index) total payoff result.2.1) =
+      terminalProposalPotential (PMF.uniformOfFintype Index) total payoff state.1 := by
+  have h := congrArg (fun law : SPMF (List Index) => ∑' word, Pr[= word | law] * payoff word)
+    (proposalCompletedRun_complete parameter root otsSecret labels inputs hencoding selections rows dummy slot budget required stopAfter
+      hauxiliary adversary state hvalid hcovered total)
+  rw [tsum_probOutput_bind_mul] at h
+  simpa only [terminalProposalPotential, SPMF.probOutput_liftM] using h
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessReference.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessReference.lean
new file mode 100644
index 000000000..20bb8645d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessReference.lean
@@ -0,0 +1,122 @@
+import SphincsSecurity.Proof.Forced.FtsGuessProgram
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec OtsContactTrace CanonicalProbeRouting
+open FtsGuessSigning (Coordinate)
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+  frontierRoot maskOtsPrefixes frontierSigningRun boundaryEval
+
+def known (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels) : Labels :=
+  CanonicalCoordinate.value otsSecret (fun _ _ _ => 0) labels
+
+theorem known_agrees (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (labels : CanonicalGraphLabels) (words : OtsReferenceWords) :
+    PublicAgreement words (fun _ _ _ => False) (known otsSecret labels) (CanonicalCoordinate.value otsSecret ftsSecret labels) := by
+  intro coordinate hpublic
+  cases coordinate with
+  | otsStart => rfl
+  | graph => rfl
+  | ftsStart => exact (hpublic (by change ¬False; exact not_false)).elim
+
+noncomputable def referenceAnswers (parameter : PublicParameter) (root : Digest)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest) (labels : CanonicalGraphLabels)
+    (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+    (auxiliary : ReferenceAuxiliary inputs) (dummy : OtsReferenceWords) : QueryImpl Auxiliary ProbComp :=
+  auxiliaryAnswers parameter otsSecret labels
+    (finiteHashAnswer ∅ inputs (canonicalReferenceResidual parameter inputs hencoding labels auxiliary.rows auxiliary.seed))
+    (publicSigningRecord parameter root
+      (finiteHashAnswer ∅ inputs (knownReferenceResidual parameter inputs hencoding (known otsSecret labels) auxiliary.rows auxiliary.seed))
+      (known otsSecret labels) (referenceFamilyWords auxiliary.selections dummy) auxiliary.selections)
+
+theorem reference_signer (key : SecretKey) (root : Digest) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary inputs) (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support)
+    (dummy : OtsReferenceWords) (message : Message) :
+    (Prod.map Prod.fst id) <$> (completePublicSigningRecord key.ftsSecret <$>
+      publicSigningRecord key.parameter root
+        (finiteHashAnswer ∅ inputs (knownReferenceResidual key.parameter inputs hencoding (known key.otsSecret labels)
+          auxiliary.rows auxiliary.seed))
+        (known key.otsSecret labels) (referenceFamilyWords auxiliary.selections dummy) auxiliary.selections message) =
+      frontierSigningRun key.parameter root
+        (maskOtsPrefixes key.parameter (referenceFamilyWords auxiliary.selections dummy)
+          (programmedHash key.parameter key.otsSecret key.ftsSecret labels
+            (finiteHashAnswer ∅ inputs (canonicalReferenceResidual key.parameter inputs hencoding labels auxiliary.rows auxiliary.seed))))
+        key.ftsSecret (referenceFamilyWords auxiliary.selections dummy)
+        (canonicalGraphFrontier key.otsSecret labels (referenceFamilyWords auxiliary.selections dummy)) message := by
+  rw [← frontierSigningRun_eq_of_agree key.parameter _ _ _ (maskOtsPrefixes_agrees key.parameter _ _),
+    frontierSigningRun, frontierSigningRecord_auxiliary_public key root inputs hencoding labels auxiliary hauxiliary dummy
+      (fun _ _ _ => False) (known key.otsSecret labels) (known_agrees key.otsSecret key.ftsSecret labels _) message]
+
+theorem fixed_reference_adversaryRun {Result : Type} (key : SecretKey) (root : Digest) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary inputs) (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support)
+    (dummy : OtsReferenceWords) (computation : OracleComp (OracleWorld + SigningSpec) Result) :
+    simulateQ (fixedAnswers (referenceAnswers key.parameter root key.otsSecret labels inputs hencoding auxiliary dummy)
+      (FtsGuessSigning.secretTable key.ftsSecret)) (adversaryRun key.parameter labels computation) =
+      fixedTrace
+        (programmedHash key.parameter key.otsSecret key.ftsSecret labels
+          (finiteHashAnswer ∅ inputs (canonicalReferenceResidual key.parameter inputs hencoding labels auxiliary.rows auxiliary.seed)))
+        (CausalFrontierProgram.adversaryRun key.parameter root
+          (programmedHash key.parameter key.otsSecret key.ftsSecret labels
+            (finiteHashAnswer ∅ inputs (canonicalReferenceResidual key.parameter inputs hencoding labels auxiliary.rows auxiliary.seed)))
+          key.ftsSecret (referenceFamilyWords auxiliary.selections dummy)
+          (canonicalGraphFrontier key.otsSecret labels (referenceFamilyWords auxiliary.selections dummy)) computation) := by
+  rw [referenceAnswers, fixed_adversaryRun]
+  simp only [reference_signer key root inputs hencoding labels auxiliary hauxiliary dummy]
+  exact (native_adversaryRun _ _ _ _ _ _ computation).symm
+
+noncomputable def completedAtRoot (parameter : PublicParameter) (root : Digest) (f : QueryImpl HashSpec Id)
+    (before : AdversaryTrace) : AdversaryTrace × (Bool × SigningBoundaryTrace) × Trace :=
+  (before, boundaryEval parameter f (verify ⟨root, parameter⟩ before.1.1.1.message before.1.1.1.signature),
+    answerTrace f (verify ⟨root, parameter⟩ before.1.1.1.message before.1.1.1.signature))
+
+theorem fixed_reference_completedRun (key : SecretKey) (root : Digest) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary inputs) (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    simulateQ (fixedAnswers (referenceAnswers key.parameter root key.otsSecret labels inputs hencoding auxiliary dummy)
+      (FtsGuessSigning.secretTable key.ftsSecret)) (completedRun key.parameter root labels adversary) =
+      completedAtRoot key.parameter root
+        (programmedHash key.parameter key.otsSecret key.ftsSecret labels
+          (finiteHashAnswer ∅ inputs (canonicalReferenceResidual key.parameter inputs hencoding labels auxiliary.rows auxiliary.seed))) <$>
+        fixedTrace
+          (programmedHash key.parameter key.otsSecret key.ftsSecret labels
+            (finiteHashAnswer ∅ inputs (canonicalReferenceResidual key.parameter inputs hencoding labels auxiliary.rows auxiliary.seed)))
+          (CausalFrontierProgram.adversaryRun key.parameter root
+            (programmedHash key.parameter key.otsSecret key.ftsSecret labels
+              (finiteHashAnswer ∅ inputs (canonicalReferenceResidual key.parameter inputs hencoding labels auxiliary.rows auxiliary.seed)))
+            key.ftsSecret (referenceFamilyWords auxiliary.selections dummy)
+            (canonicalGraphFrontier key.otsSecret labels (referenceFamilyWords auxiliary.selections dummy))
+            (adversary.main ⟨root, key.parameter⟩)) := by
+  rw [completedRun, simulateQ_bind, fixed_reference_adversaryRun key root inputs hencoding labels auxiliary hauxiliary dummy,
+    map_eq_bind_pure_comp]
+  apply bind_congr
+  intro before
+  simp only [simulateQ_bind, referenceAnswers, fixed_verifyProgram, pure_bind, simulateQ_pure, Function.comp_def, completedAtRoot]
+
+theorem reference_root (key : SecretKey) (labels : CanonicalGraphLabels) (residual : QueryImpl HashSpec Id)
+    (words : OtsReferenceWords) :
+    frontierRoot key.parameter
+      (maskOtsPrefixes key.parameter words (programmedHash key.parameter key.otsSecret key.ftsSecret labels residual))
+      words (canonicalGraphFrontier key.otsSecret labels words) = canonicalGraphRoot labels := by
+  rw [← frontierRoot_eq_of_agree key.parameter words _ _ (maskOtsPrefixes_agrees key.parameter words _)]
+  exact frontierRoot_of_graph key _ labels words (canonicalGraphLabels_programmedHash _ _ _ _ _)
+
+theorem fixed_reference_completedForgeryRest (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary inputs) (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    simulateQ (fixedAnswers (referenceAnswers key.parameter (canonicalGraphRoot labels) key.otsSecret labels inputs hencoding auxiliary dummy)
+      (FtsGuessSigning.secretTable key.ftsSecret)) (completedRun key.parameter (canonicalGraphRoot labels) labels adversary) =
+      completedAtRoot key.parameter (canonicalGraphRoot labels)
+        (programmedHash key.parameter key.otsSecret key.ftsSecret labels
+          (finiteHashAnswer ∅ inputs (canonicalReferenceResidual key.parameter inputs hencoding labels auxiliary.rows auxiliary.seed))) <$>
+        referenceForgeryRest key
+          (programmedHash key.parameter key.otsSecret key.ftsSecret labels
+            (finiteHashAnswer ∅ inputs (canonicalReferenceResidual key.parameter inputs hencoding labels auxiliary.rows auxiliary.seed)))
+          labels auxiliary.selections dummy adversary := by
+  rw [referenceForgeryRest, reference_root]
+  exact fixed_reference_completedRun key (canonicalGraphRoot labels) inputs hencoding labels auxiliary hauxiliary dummy adversary
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessReferenceWitness.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessReferenceWitness.lean
new file mode 100644
index 000000000..b685b7b62
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessReferenceWitness.lean
@@ -0,0 +1,110 @@
+import SphincsSecurity.Proof.Forced.FtsGuessWitness
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec OtsContactTrace
+open FtsGuessSigning (Coordinate)
+open SecretGuessObservation (State fixedRun lazyRun initialState)
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+  frontierRoot maskOtsPrefixes frontierSigningRun boundaryEval programmedHash fixedBoundaryRun signWithView publicSigningRecord
+
+private theorem map_nonzero {First Result : Type} (function : First → Result) (law : SPMF First) (result : Result) :
+    (function <$> law) result ≠ 0 ↔ ∃ first, law first ≠ 0 ∧ result = function first := by
+  simp only [map_eq_bind_pure_comp, RetainedObservation.bind_nonzero, Function.comp_def,
+    ne_eq, SPMF.pure_apply_eq_zero_iff, not_not]
+
+private theorem signing_record_view (key : SecretKey) (f : QueryImpl HashSpec Id) (message : Message)
+    (record : (Option Signature × Option FewTimeView) × SigningBoundaryTrace)
+    (hr : 𝒟[fixedBoundaryRun key.parameter f (signWithView key message)] record ≠ 0)
+    (signature : Signature) (hs : record.1.1 = some signature) :
+    record.1.2 = some (RetainedResidual.signingView key f message signature) := by
+  have hrecord : 𝒟[fixedBoundaryRun key.parameter f (signWithView key message)]
+      ((some signature, record.1.2), record.2) ≠ 0 := by
+    simpa only [← hs] using hr
+  exact (RetainedResidual.fixedBoundaryRun_signing_origin key f message signature record.1.2 record.2 hrecord).1
+
+theorem fixed_signingProgram_view (auxiliary : QueryImpl Auxiliary ProbComp) (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (hsigner : ∀ message, completePublicSigningRecord key.ftsSecret <$> auxiliary (.inr message) =
+      fixedBoundaryRun key.parameter f (signWithView key message))
+    (message : Message) (state : State Coordinate Digest PUnit)
+    (result : ((Option Signature × Option FewTimeView) × SigningBoundaryTrace) × State Coordinate Digest PUnit)
+    (hr : fixedRun (SecretGuessObservation.environment auxiliary) (FtsGuessSigning.secretTable key.ftsSecret)
+      (signingProgram message) state result ≠ 0)
+    (signature : Signature) (hs : result.1.1.1 = some signature) :
+    result.1.1.2 = some (RetainedResidual.signingView key f message signature) := by
+  have hprojected := (map_nonzero Prod.fst _ result.1).mpr ⟨result, hr, rfl⟩
+  rw [SecretGuessObservation.fixedRun_projection, fixed_signingProgram] at hprojected
+  change 𝒟[completePublicSigningRecord key.ftsSecret <$> auxiliary (.inr message)] result.1 ≠ 0 at hprojected
+  rw [hsigner] at hprojected
+  exact signing_record_view key f message result.1 hprojected signature hs
+
+theorem fixed_reference_signingProgram_view (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary inputs) (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support)
+    (dummy : OtsReferenceWords) (message : Message) (state : State Coordinate Digest PUnit)
+    (result : ((Option Signature × Option FewTimeView) × SigningBoundaryTrace) × State Coordinate Digest PUnit)
+    (hr : fixedRun
+      (SecretGuessObservation.environment (referenceAnswers key.parameter key.root key.otsSecret labels inputs hencoding auxiliary dummy))
+      (FtsGuessSigning.secretTable key.ftsSecret) (signingProgram message) state result ≠ 0)
+    (signature : Signature) (hs : result.1.1.1 = some signature) :
+    result.1.1.2 = some (RetainedResidual.signingView key
+      (programmedHash key.parameter key.otsSecret key.ftsSecret labels
+        (finiteHashAnswer ∅ inputs (canonicalReferenceResidual key.parameter inputs hencoding labels auxiliary.rows auxiliary.seed)))
+      message signature) := by
+  apply fixed_signingProgram_view _ key _ _ message state result hr signature hs
+  intro message
+  change (completePublicSigningRecord key.ftsSecret <$>
+    publicSigningRecord key.parameter key.root
+      (finiteHashAnswer ∅ inputs (knownReferenceResidual key.parameter inputs hencoding (known key.otsSecret labels) auxiliary.rows auxiliary.seed))
+      (known key.otsSecret labels) (referenceFamilyWords auxiliary.selections dummy) auxiliary.selections message) = _
+  exact (fixedBoundaryRun_signWithView_auxiliary_public key inputs hencoding labels auxiliary hauxiliary dummy
+    (fun _ _ _ => False) (known key.otsSecret labels) (known_agrees key.otsSecret key.ftsSecret labels _) message).symm
+
+theorem fixed_reference_completedRun_tracking (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary inputs) (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support)
+    (dummy : OtsReferenceWords) (adversary : Adversary) (state : State Coordinate Digest PUnit)
+    (result : Completed × State Coordinate Digest PUnit)
+    (hr : fixedRun
+      (SecretGuessObservation.environment (referenceAnswers key.parameter key.root key.otsSecret labels inputs hencoding auxiliary dummy))
+      (FtsGuessSigning.secretTable key.ftsSecret) (completedRun key.parameter key.root labels adversary) state result ≠ 0) :
+    Tracking key
+      (programmedHash key.parameter key.otsSecret key.ftsSecret labels
+        (finiteHashAnswer ∅ inputs (canonicalReferenceResidual key.parameter inputs hencoding labels auxiliary.rows auxiliary.seed)))
+      state result.2 result.1.1.1.1.2 (result.1.1.2 * result.1.2.2) := by
+  apply fixed_completedRun_tracking _ key _ labels _ adversary state result hr
+  exact fixed_reference_signingProgram_view key inputs hencoding labels auxiliary hauxiliary dummy
+
+theorem fixedRun_nonzero_of_lazy_posterior {Memory Result : Type}
+    (environment : SecretGuessObservation.Environment Auxiliary Coordinate Digest Memory)
+    (computation : OracleComp World Result) (state : State Coordinate Digest Memory)
+    (result : Result × State Coordinate Digest Memory) (secrets : Coordinate → Digest)
+    (hr : lazyRun environment computation state result ≠ 0)
+    (hsecrets : UniformTableCompletion.complete result.2.allowed secrets ≠ 0) :
+    fixedRun environment secrets computation state result ≠ 0 := by
+  have hjoint : (lazyRun environment computation state >>= fun result =>
+      (fun secrets => (secrets, result)) <$> UniformTableCompletion.complete result.2.allowed) (secrets, result) ≠ 0 :=
+    (RetainedObservation.bind_nonzero _ _ _).mpr ⟨result, hr, (map_nonzero _ _ _).mpr ⟨secrets, hsecrets, rfl⟩⟩
+  rw [← SecretGuessObservation.run_posterior, RetainedObservation.bind_nonzero] at hjoint
+  obtain ⟨draw, _, hjoint⟩ := hjoint
+  obtain ⟨outcome, houtcome, heq⟩ := (map_nonzero _ _ _).mp hjoint
+  obtain ⟨rfl, rfl⟩ := Prod.mk.inj heq
+  exact houtcome
+
+theorem lazy_reference_completedRun_tracking (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary inputs) (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support)
+    (dummy : OtsReferenceWords) (adversary : Adversary) (state : State Coordinate Digest PUnit)
+    (result : Completed × State Coordinate Digest PUnit)
+    (hr : lazyRun
+      (SecretGuessObservation.environment (referenceAnswers key.parameter key.root key.otsSecret labels inputs hencoding auxiliary dummy))
+      (completedRun key.parameter key.root labels adversary) state result ≠ 0)
+    (hsecrets : UniformTableCompletion.complete result.2.allowed (FtsGuessSigning.secretTable key.ftsSecret) ≠ 0) :
+    Tracking key
+      (programmedHash key.parameter key.otsSecret key.ftsSecret labels
+        (finiteHashAnswer ∅ inputs (canonicalReferenceResidual key.parameter inputs hencoding labels auxiliary.rows auxiliary.seed)))
+      state result.2 result.1.1.1.1.2 (result.1.1.2 * result.1.2.2) :=
+  fixed_reference_completedRun_tracking key inputs hencoding labels auxiliary hauxiliary dummy adversary state result
+    (fixedRun_nonzero_of_lazy_posterior _ _ state result _ hr hsecrets)
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessRemaining.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessRemaining.lean
new file mode 100644
index 000000000..ac6779154
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessRemaining.lean
@@ -0,0 +1,65 @@
+import SphincsSecurity.Proof.Forced.FtsGuessPairSource
+import SphincsSecurity.Proof.Reference.ReferenceCertificateCoverage
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open RetainedResidual (signingInput)
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  frontierRoot maskOtsPrefixes frontierSigningRun boundaryEval honestNode canonicalGraphLabels
+
+noncomputable def ReferenceForgerySample.nearGuess {inputs : Finset HashInput} (dummy : OtsReferenceWords)
+    (sample : ReferenceForgerySample inputs) : Prop :=
+  let f := finiteHashAnswer ∅ inputs sample.2.1.2
+  let key := ReferenceVerifierWitness.rootedKey sample.1 f
+  let result := (sample.context dummy).2.2.2
+  SigningTranscript.Valid sample.2.2.1.1.2 ∧
+    ReferenceFtsCoverage.NearGuess key f sample.2.2.1.1.2 sample.2.2.1.2
+      (result.before * result.after) sample.2.2.1.1.1
+
+theorem ReferenceForgerySample.remainingFts_cases {inputs : Finset HashInput} (dummy : OtsReferenceWords)
+    (sample : ReferenceForgerySample inputs) (h : sample.remainingFts dummy) :
+    FtsGuessHash.referenceTwoGuesses dummy sample ∨ sample.nearGuess dummy := by
+  rcases h with ⟨hvalid, h | h⟩
+  · exact Or.inr ⟨hvalid, h⟩
+  · exact Or.inl h
+
+theorem referenceForgeryGame_remainingFts_le (dummy : OtsReferenceWords) (adversary : Adversary) (budget : Nat)
+    (hbudget : HasHashQueryBound scheme adversary budget) :
+    Pr[ReferenceForgerySample.remainingFts dummy | referenceForgeryGame (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] ≤
+      FtsGuessHash.pairRate budget +
+      Pr[ReferenceForgerySample.nearGuess dummy | referenceForgeryGame (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] := by
+  refine (_root_.probEvent_mono'' (mx := referenceForgeryGame (canonicalGraphGameInputs adversary)
+    (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary)
+    (fun sample h => sample.remainingFts_cases dummy h)).trans ?_
+  exact (probEvent_or_le _ _ _).trans
+    (add_le_add (FtsGuessHash.referenceForgeryGame_two_guesses dummy adversary budget hbudget) le_rfl)
+
+theorem forgeAdvantage_le_nearGuess_small_budget (dummy : OtsReferenceWords)
+    (hdummy : ∀ lay tree leaf, TargetSum.Valid (dummy lay tree leaf))
+    (adversary : Adversary) (q : Nat) (hbound : HasHashQueryBound scheme adversary q)
+    (hsmall : q ≤ 3 * 2 ^ 114) :
+    forgeAdvantage scheme adversary ≤
+      (7 / 4 : ENNReal) * ((q : ENNReal) / 2 ^ 128) + (q : ENNReal) * (11 / 2 ^ 144 : ENNReal) +
+      (2 ^ 700 : ENNReal)⁻¹ + FtsGuessHash.pairRate q +
+      Pr[ReferenceForgerySample.nearGuess dummy | referenceForgeryGame (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] := by
+  have h := (forgeAdvantage_le_remainingFts_small_budget dummy hdummy adversary q hbound hsmall).trans
+    (add_le_add le_rfl (referenceForgeryGame_remainingFts_le dummy adversary q hbound))
+  simpa only [add_assoc] using h
+
+theorem forgeAdvantage_le_nearGuess_normalized_small_budget (dummy : OtsReferenceWords)
+    (hdummy : ∀ lay tree leaf, TargetSum.Valid (dummy lay tree leaf))
+    (adversary : Adversary) (q : Nat) (hbound : HasHashQueryBound scheme adversary q)
+    (hsmall : q ≤ 3 * 2 ^ 114) :
+    forgeAdvantage scheme adversary ≤
+      (7 / 4 : ENNReal) * ((q : ENNReal) / 2 ^ 128) + (q : ENNReal) * (11 / 2 ^ 144 : ENNReal) +
+      (2 ^ 700 : ENNReal)⁻¹ + ((q : ENNReal) / 2 ^ 128) ^ 2 / (2 * (1 - (q : ENNReal) / 2 ^ 128) ^ 2) +
+      Pr[ReferenceForgerySample.nearGuess dummy | referenceForgeryGame (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] :=
+  (forgeAdvantage_le_nearGuess_small_budget dummy hdummy adversary q hbound hsmall).trans
+    (add_le_add (add_le_add le_rfl (FtsGuessHash.pairRate_le_normalized q)) le_rfl)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessSeedCache.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessSeedCache.lean
new file mode 100644
index 000000000..d5b95755a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessSeedCache.lean
@@ -0,0 +1,78 @@
+import SphincsSecurity.Proof.Forced.FtsGuessDeferredMessage
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec UniformTableCompletion
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+def seedAllowed (inputs : Finset HashInput) (cache : QueryCache HashSpec) : inputs → Finset HashOutput :=
+  fun input => (cache input.val).elim Finset.univ (fun answer => {answer})
+
+theorem seedAllowed_cacheQuery (inputs : Finset HashInput) (cache : QueryCache HashSpec)
+    (input : inputs) (answer : HashOutput) :
+    seedAllowed inputs (cache.cacheQuery input.val answer) = discloseTableValue (seedAllowed inputs cache) input answer := by
+  funext other
+  by_cases he : other = input
+  · subst other
+    simp only [seedAllowed, QueryCache.cacheQuery, Function.update_self, Option.elim_some, discloseTableValue]
+  · have hv : other.val ≠ input.val := fun hv => he (Subtype.ext hv)
+    simp only [seedAllowed, QueryCache.cacheQuery, Function.update_of_ne hv, discloseTableValue, Function.update_of_ne he]
+
+private theorem cell_singleton (answer : HashOutput) : cell {answer} = pure answer := by
+  apply SPMF.ext
+  intro value
+  simp only [cell_apply, Finset.mem_singleton, Finset.card_singleton, Nat.cast_one, inv_one, SPMF.pure_apply]
+
+noncomputable def cachedSeedImpl (inputs : Finset HashInput) :
+    QueryImpl (ForcedSeedSpec inputs) (StateT (QueryCache HashSpec) SPMF)
+  | .inl input => StateT.mk fun cache => (fun answer => (answer, cache)) <$> forcedSeedAuxiliary input
+  | .inr input => StateT.mk fun cache => 𝒟[(randomOracle (spec := HashSpec) input.val).run cache]
+
+noncomputable def cachedSeedRun {Result : Type} (inputs : Finset HashInput)
+    (computation : OracleComp (ForcedSeedSpec inputs) Result) (cache : QueryCache HashSpec) :
+    SPMF (Result × QueryCache HashSpec) := (simulateQ (cachedSeedImpl inputs) computation).run cache
+
+theorem cachedSeedImpl_project (inputs : Finset HashInput) (input : (ForcedSeedSpec inputs).Domain)
+    (cache : QueryCache HashSpec) :
+    (Prod.map id (seedAllowed inputs)) <$> (cachedSeedImpl inputs input).run cache =
+      (UniformTableObservation.lazyImpl forcedSeedAuxiliary input).run (seedAllowed inputs cache) := by
+  cases input with
+  | inl input => simp only [cachedSeedImpl, UniformTableObservation.lazyImpl, StateT.run_mk, Functor.map_map]; rfl
+  | inr input =>
+      cases hc : cache input.val with
+      | none =>
+          rw [cachedSeedImpl, StateT.run_mk, randomOracle, QueryImpl.withCaching_run_none _ hc]
+          simp only [uniformSampleImpl, evalDist_map, evalDist_uniformSample, Functor.map_map,
+            UniformTableObservation.lazyImpl, StateT.run_mk, seedAllowed, hc, Option.elim_none,
+            cell, dif_pos Finset.univ_nonempty]
+          congr 1
+          funext answer
+          exact Prod.ext rfl (seedAllowed_cacheQuery inputs cache input answer)
+      | some answer =>
+          rw [cachedSeedImpl, StateT.run_mk, randomOracle, QueryImpl.withCaching_run_some _ hc]
+          simp only [evalDist_pure, map_pure, UniformTableObservation.lazyImpl, StateT.run_mk,
+            seedAllowed, hc, Option.elim_some, Prod.map_apply, id_eq]
+          change pure (answer, seedAllowed inputs cache) =
+            ((fun value : HashOutput => (value, discloseTableValue (seedAllowed inputs cache) input value)) <$> cell {answer})
+          rw [cell_singleton, map_pure]
+          apply congrArg pure
+          apply congrArg (fun allowed : inputs → Finset HashOutput => (answer, allowed))
+          symm
+          have ha : seedAllowed inputs cache input = {answer} := by simp only [seedAllowed, hc, Option.elim_some]
+          rw [discloseTableValue, ← ha, Function.update_eq_self]
+
+theorem cachedSeedRun_project {Result : Type} (inputs : Finset HashInput)
+    (computation : OracleComp (ForcedSeedSpec inputs) Result) (cache : QueryCache HashSpec) :
+    (Prod.map id (seedAllowed inputs)) <$> cachedSeedRun inputs computation cache =
+      UniformTableObservation.lazyRun forcedSeedAuxiliary computation (seedAllowed inputs cache) := by
+  induction computation using OracleComp.inductionOn generalizing cache with
+  | pure value => simp only [cachedSeedRun, simulateQ_pure, StateT.run_pure, map_pure, UniformTableObservation.lazyRun_pure]; rfl
+  | query_bind input next ih =>
+      simp only [cachedSeedRun, simulateQ_bind, simulateQ_spec_query, StateT.run_bind, map_bind]
+      change ((cachedSeedImpl inputs input).run cache >>= fun result =>
+        (Prod.map id (seedAllowed inputs)) <$> cachedSeedRun inputs (next result.1) result.2) = _
+      simp only [ih]
+      rw [UniformTableObservation.lazyRun_query_bind, ← cachedSeedImpl_project inputs input cache, bind_map_left]
+      rfl
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessSigning.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessSigning.lean
new file mode 100644
index 000000000..48e5a6915
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessSigning.lean
@@ -0,0 +1,117 @@
+import SphincsSecurity.Proof.Forced.SecretGuessObservation
+import SphincsSecurity.Proof.Reference.ReferenceAuxiliarySigning
+import SphincsSecurity.Proof.Base.UniformTableProducts
+namespace SphincsSecurity.Concrete.FtsGuessSigning
+
+open _root_.OracleComp OracleSpec SecretGuessObservation CanonicalProbeRouting UniformTableCompletion
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+abbrev Coordinate := Index × FtsTree × FtsLeaf
+
+def secretTable : (Index → FtsTree → FtsLeaf → Digest) ≃ (Coordinate → Digest) where
+  toFun secrets coordinate := secrets coordinate.1 coordinate.2.1 coordinate.2.2
+  invFun table index tree leaf := table (index, tree, leaf)
+  left_inv _ := rfl
+  right_inv _ := rfl
+
+theorem sampleFtsSecrets_table : secretTable <$> 𝒟[sampleFtsSecrets] =
+    complete (fun _ : Coordinate => (Finset.univ : Finset Digest)) := by
+  rw [sampleFtsSecrets, evalDist_uniformSample, complete_of_nonempty _ (fun _ => Finset.univ_nonempty), uniformTable_univ]
+  have h := congrArg (fun law : PMF (Coordinate → Digest) => 𝒟[law])
+    (PMF.uniformOfFintype_map_of_bijective secretTable secretTable.bijective)
+  simpa only [← PMF.monad_map_eq_map, evalDist_map] using h
+
+variable {AuxIndex Memory : Type} {auxSpec : OracleSpec AuxIndex}
+
+def completeRecord (record : PublicSigningRecord) :
+    OracleComp (World auxSpec Coordinate Digest) ((Option Signature × Option FewTimeView) × SigningBoundaryTrace) :=
+  match record.1.1, record.1.2 with
+  | some plan, some view => do
+      let secrets ← sequenceFin fun tree => disclosure (view.1, tree, view.2 tree)
+      pure ((some (plan.finish secrets), some view), record.2)
+  | _, _ => pure ((none, record.1.2), record.2)
+
+def completedState (environment : Environment auxSpec Coordinate Digest Memory) (labels : Coordinate → Digest)
+    (record : PublicSigningRecord) (state : State Coordinate Digest Memory) : State Coordinate Digest Memory :=
+  match record.1.1, record.1.2 with
+  | some _, some view => disclosureSequenceState environment labels (fun tree => (view.1, tree, view.2 tree)) state
+  | _, _ => state
+
+theorem completedState_counts (environment : Environment auxSpec Coordinate Digest Memory) (labels : Coordinate → Digest)
+    (record : PublicSigningRecord) (state : State Coordinate Digest Memory) :
+    ((completedState environment labels record state).guesses,
+      (completedState environment labels record state).probes) = (state.guesses, state.probes) := by
+  obtain ⟨⟨plan, view⟩, trace⟩ := record
+  cases plan with
+  | none => rfl
+  | some plan =>
+      cases view with
+      | none => rfl
+      | some view => exact disclosureSequenceState_counts environment labels (fun tree : FtsTree => (view.1, tree, view.2 tree)) state
+
+theorem fixedRun_completeRecord (environment : Environment auxSpec Coordinate Digest Memory) (labels : Coordinate → Digest)
+    (record : PublicSigningRecord) (state : State Coordinate Digest Memory) :
+    fixedRun environment labels (completeRecord record) state =
+      pure (completePublicSigningRecord (fun index tree leaf => labels (index, tree, leaf)) record,
+        completedState environment labels record state) := by
+  obtain ⟨⟨plan, view⟩, trace⟩ := record
+  cases plan <;> cases view <;> simp only [completeRecord, completePublicSigningRecord, completedState,
+    Option.map_none, Option.map_some]
+  all_goals first
+    | exact runWith_pure (fixedImpl environment labels) _ _
+    | rw [fixedRun_disclosureSequence_bind]; exact runWith_pure (fixedImpl environment labels) _ _
+
+noncomputable def nativeRun (environment : Environment auxSpec Coordinate Digest Memory) (labels : Coordinate → Digest)
+    (state : State Coordinate Digest Memory) (parameter : PublicParameter) (root : Digest) (outside : QueryImpl HashSpec Id)
+    (known : Labels) (words : OtsReferenceWords) (selections : ReferenceFamily) (message : Message) :
+    SPMF (((Option Signature × Option FewTimeView) × SigningBoundaryTrace) × State Coordinate Digest Memory) :=
+  𝒟[publicSigningRecord parameter root outside known words selections message] >>= fun record =>
+    fixedRun environment labels (completeRecord record) state
+
+noncomputable def lazySigningRun (environment : Environment auxSpec Coordinate Digest Memory)
+    (state : State Coordinate Digest Memory) (parameter : PublicParameter) (root : Digest) (outside : QueryImpl HashSpec Id)
+    (known : Labels) (words : OtsReferenceWords) (selections : ReferenceFamily) (message : Message) :
+    SPMF (((Option Signature × Option FewTimeView) × SigningBoundaryTrace) × State Coordinate Digest Memory) :=
+  𝒟[publicSigningRecord parameter root outside known words selections message] >>= fun record =>
+    lazyRun environment (completeRecord record) state
+
+theorem nativeRun_erasure (environment : Environment auxSpec Coordinate Digest Memory) (labels : Coordinate → Digest)
+    (state : State Coordinate Digest Memory) (parameter : PublicParameter) (root : Digest) (outside : QueryImpl HashSpec Id)
+    (known : Labels) (words : OtsReferenceWords) (selections : ReferenceFamily) (message : Message) :
+    Prod.fst <$> nativeRun environment labels state parameter root outside known words selections message =
+      𝒟[completePublicSigningRecord (fun index tree leaf => labels (index, tree, leaf)) <$>
+        publicSigningRecord parameter root outside known words selections message] := by
+  simp only [nativeRun, fixedRun_completeRecord, map_eq_bind_pure_comp, evalDist_bind, evalDist_pure,
+    bind_assoc, pure_bind, Function.comp_def]
+
+theorem nativeRun_original (environment : Environment auxSpec Coordinate Digest Memory)
+    (state : State Coordinate Digest Memory) (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary inputs) (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support)
+    (dummy : OtsReferenceWords) (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels)
+    (hagrees : PublicAgreement (referenceFamilyWords auxiliary.selections dummy) disclosed known
+      (CanonicalCoordinate.value key.otsSecret key.ftsSecret labels)) (message : Message) :
+    Prod.fst <$> nativeRun environment (fun coordinate => key.ftsSecret coordinate.1 coordinate.2.1 coordinate.2.2) state
+        key.parameter key.root
+        (finiteHashAnswer ∅ inputs (knownReferenceResidual key.parameter inputs hencoding known auxiliary.rows auxiliary.seed))
+        known (referenceFamilyWords auxiliary.selections dummy) auxiliary.selections message =
+      𝒟[fixedBoundaryRun key.parameter
+        (programmedHash key.parameter key.otsSecret key.ftsSecret labels
+          (finiteHashAnswer ∅ inputs (canonicalReferenceResidual key.parameter inputs hencoding labels auxiliary.rows auxiliary.seed)))
+        (signWithView key message)] := by
+  rw [nativeRun_erasure,
+    fixedBoundaryRun_signWithView_auxiliary_public key inputs hencoding labels auxiliary hauxiliary dummy disclosed known hagrees message]
+
+theorem signingRun_erasure (environment : Environment auxSpec Coordinate Digest Memory)
+    (state : State Coordinate Digest Memory) (ha : ∀ coordinate, (state.allowed coordinate).Nonempty)
+    (parameter : PublicParameter) (root : Digest) (outside : QueryImpl HashSpec Id)
+    (known : Labels) (words : OtsReferenceWords) (selections : ReferenceFamily) (message : Message) :
+    (complete state.allowed >>= fun labels => nativeRun environment labels state parameter root outside known words selections message) =
+      lazySigningRun environment state parameter root outside known words selections message := by
+  simp only [nativeRun, lazySigningRun]
+  rw [RetainedObservation.bind_comm]
+  exact congrArg (𝒟[publicSigningRecord parameter root outside known words selections message] >>= ·)
+    (funext fun record => run_erasure environment (completeRecord record) state ha)
+
+end SphincsSecurity.Concrete.FtsGuessSigning
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessTracking.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessTracking.lean
new file mode 100644
index 000000000..e763e5e09
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessTracking.lean
@@ -0,0 +1,213 @@
+import SphincsSecurity.Proof.Forced.FtsGuessWork
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec OtsContactTrace
+open FtsGuessSigning (Coordinate)
+open SecretGuessObservation (State Environment fixedRun fixedImpl runWith afterTrial)
+set_option backward.isDefEq.respectTransparency false
+
+variable {Memory : Type}
+
+def Covered (key : SecretKey) (f : QueryImpl HashSpec Id) (log : QueryLog SigningSpec) (coordinate : Coordinate) : Prop :=
+  ∃ message signature, (⟨message, some signature⟩ : SigningEntry) ∈ log ∧
+    (RetainedResidual.signingView key f message signature).1 = coordinate.1 ∧
+    (RetainedResidual.signingView key f message signature).2 coordinate.2.1 = coordinate.2.2
+
+structure Tracking (key : SecretKey) (f : QueryImpl HashSpec Id) (before after : State Coordinate Digest Memory)
+    (log : QueryLog SigningSpec) (trace : Trace) : Prop where
+  guesses : before.guesses ⊆ after.guesses
+  retired : before.retired ⊆ after.retired
+  origin : ∀ coordinate ∈ after.retired, coordinate ∈ before.retired ∨ coordinate ∈ after.guesses ∨ Covered key f log coordinate
+  queried : ∀ coordinate, FtsVerifierWitness.TrueSecretQuery f key coordinate.1 coordinate.2.1 coordinate.2.2 trace →
+    coordinate ∈ after.retired
+
+theorem Tracking.refl (key : SecretKey) (f : QueryImpl HashSpec Id) (state : State Coordinate Digest Memory) :
+    Tracking key f state state [] 1 := by
+  refine ⟨Finset.Subset.refl _, Finset.Subset.refl _, fun _ h => Or.inl h, ?_⟩
+  intro coordinate h
+  cases h
+
+theorem Tracking.trans {key : SecretKey} {f : QueryImpl HashSpec Id} {before middle after : State Coordinate Digest Memory}
+    {firstLog secondLog : QueryLog SigningSpec} {firstTrace secondTrace : Trace}
+    (first : Tracking key f before middle firstLog firstTrace) (second : Tracking key f middle after secondLog secondTrace) :
+    Tracking key f before after (firstLog ++ secondLog) (firstTrace * secondTrace) := by
+  refine ⟨first.guesses.trans second.guesses, first.retired.trans second.retired, ?_, ?_⟩
+  · intro coordinate h
+    rcases second.origin coordinate h with h | h | h
+    · rcases first.origin coordinate h with h | h | ⟨message, signature, hm, hi, hl⟩
+      · exact Or.inl h
+      · exact Or.inr (Or.inl (second.guesses h))
+      · exact Or.inr (Or.inr ⟨message, signature, List.mem_append_left _ hm, hi, hl⟩)
+    · exact Or.inr (Or.inl h)
+    · obtain ⟨message, signature, hm, hi, hl⟩ := h
+      exact Or.inr (Or.inr ⟨message, signature, List.mem_append_right _ hm, hi, hl⟩)
+  · intro coordinate h
+    rw [FtsVerifierWitness.TrueSecretQuery, FreeMonoid.toList_mul, List.mem_append] at h
+    exact h.elim (fun h => second.retired (first.queried coordinate h)) (second.queried coordinate)
+
+private theorem map_nonzero {First Result : Type} (function : First → Result) (law : SPMF First) (result : Result) :
+    (function <$> law) result ≠ 0 ↔ ∃ first, law first ≠ 0 ∧ result = function first := by
+  simp only [map_eq_bind_pure_comp, RetainedObservation.bind_nonzero, Function.comp_def,
+    ne_eq, SPMF.pure_apply_eq_zero_iff, not_not]
+
+theorem fixed_auxiliary_tracking (environment : Environment Auxiliary Coordinate Digest Memory) (secrets : Coordinate → Digest)
+    (key : SecretKey) (f : QueryImpl HashSpec Id) (input : Auxiliary.Domain)
+    (state : State Coordinate Digest Memory) (result : Auxiliary.Range input × State Coordinate Digest Memory)
+    (hr : fixedRun environment secrets (liftM (World.query (.inl input))) state result ≠ 0) :
+    Tracking key f state result.2 [] 1 := by
+  simp only [fixedRun, runWith, simulateQ_spec_query, fixedImpl, StateT.run_mk, map_nonzero] at hr
+  obtain ⟨answer, _, rfl⟩ := hr
+  have h := Tracking.refl key f state
+  exact ⟨h.guesses, h.retired, h.origin, h.queried⟩
+
+theorem afterTrial_tracking (environment : Environment Auxiliary Coordinate Digest Memory) (key : SecretKey)
+    (f : QueryImpl HashSpec Id) (state : State Coordinate Digest Memory) (coordinate : Coordinate) (candidate : Digest) (hit : Bool) :
+    Tracking key f state (afterTrial environment state coordinate candidate hit) [] 1 := by
+  classical
+  refine ⟨?_, ?_, ?_, ?_⟩
+  · simp only [afterTrial]
+    split <;> simp only [Finset.subset_insert, Finset.Subset.refl]
+  · cases hit <;> simp only [afterTrial, Bool.false_eq_true, if_false, if_true, Finset.Subset.refl, Finset.subset_insert]
+  · intro other h
+    cases hit with
+    | false => exact Or.inl h
+    | true =>
+        change other ∈ insert coordinate state.retired at h
+        rcases Finset.mem_insert.mp h with rfl | h
+        · by_cases hc : other ∈ state.retired
+          · exact Or.inl hc
+          · right; left; simp only [afterTrial, hc, not_false_eq_true, and_self, if_true, Finset.mem_insert_self]
+        · exact Or.inl h
+  · intro other h
+    cases h
+
+theorem fixed_hashProgram_tracking (environment : Environment Auxiliary Coordinate Digest Memory) (key : SecretKey)
+    (f : QueryImpl HashSpec Id) (labels : CanonicalGraphLabels) (input : HashInput)
+    (state : State Coordinate Digest Memory) (result : HashOutput × State Coordinate Digest Memory)
+    (hr : fixedRun environment (FtsGuessSigning.secretTable key.ftsSecret) (hashProgram key.parameter labels input) state result ≠ 0) :
+    Tracking key f state result.2 [] (FreeMonoid.of (input, result.1)) := by
+  have hbase : Tracking key f state result.2 [] 1 := by
+    cases hd : FtsProbeSimulation.decodeProbe? key.parameter input with
+    | none =>
+        rw [hashProgram, hd] at hr
+        exact fixed_auxiliary_tracking environment _ key f (.inl (.inr input)) state result hr
+    | some probe =>
+        rw [hashProgram, hd, fixedRun, SecretGuessObservation.runWith_query_bind] at hr
+        simp only [fixedImpl, StateT.run_mk, pure_bind] at hr
+        split at hr
+        · simp only [SecretGuessObservation.runWith_pure, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+          subst result
+          exact afterTrial_tracking environment key f state _ _ _
+        · have h := (afterTrial_tracking environment key f state _ _ _).trans
+            (fixed_auxiliary_tracking environment _ key f (.inl (.inr input)) _ result hr)
+          simpa only [List.nil_append, one_mul] using h
+  refine { hbase with queried := ?_ }
+  intro target h
+  have hi := congrArg Prod.fst (List.mem_singleton.mp h)
+  let probe : FtsSecretProbe := ⟨target.1, target.2.1, target.2.2, key.ftsSecret target.1 target.2.1 target.2.2⟩
+  have hp : probe.input key.parameter = input := hi
+  rw [hashProgram, (FtsProbeSimulation.decodeProbe?_eq_some_iff key.parameter input probe).mpr hp,
+    fixedRun, SecretGuessObservation.runWith_query_bind] at hr
+  simp only [fixedImpl, StateT.run_mk, FtsGuessSigning.secretTable, Equiv.coe_fn_mk, coordinate, probe,
+    decide_true, if_true, pure_bind, SecretGuessObservation.runWith_pure,
+    ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+  subst result
+  exact Finset.mem_insert_self _ _
+
+theorem fixed_worldProgram_tracking (environment : Environment Auxiliary Coordinate Digest Memory) (key : SecretKey)
+    (f : QueryImpl HashSpec Id) (labels : CanonicalGraphLabels) (input : OracleWorld.Domain)
+    (state : State Coordinate Digest Memory) (result : OracleWorld.Range input × State Coordinate Digest Memory)
+    (hr : fixedRun environment (FtsGuessSigning.secretTable key.ftsSecret) (worldProgram key.parameter labels input) state result ≠ 0) :
+    Tracking key f state result.2 [] (hashObservationTrace input result.1) := by
+  cases input with
+  | inl input => exact fixed_auxiliary_tracking environment _ key f (.inl (.inl input)) state result hr
+  | inr input => exact fixed_hashProgram_tracking environment key f labels input state result hr
+
+private theorem disclosureList_retired (environment : Environment Auxiliary Coordinate Digest Memory) (secrets : Coordinate → Digest)
+    (entries : List Coordinate) (state : State Coordinate Digest Memory) (target : Coordinate) :
+    target ∈ (entries.foldl (fun state coordinate =>
+      SecretGuessObservation.afterDisclosure environment state coordinate (secrets coordinate)) state).retired ↔
+        target ∈ state.retired ∨ target ∈ entries := by
+  induction entries generalizing state with
+  | nil => simp only [List.foldl_nil, List.not_mem_nil, or_false]
+  | cons coordinate entries ih =>
+      rw [List.foldl_cons, ih]
+      simp only [SecretGuessObservation.afterDisclosure, Finset.mem_insert, List.mem_cons]
+      tauto
+
+theorem completedState_retired (environment : Environment Auxiliary Coordinate Digest Memory) (secrets : Coordinate → Digest)
+    (record : PublicSigningRecord) (state : State Coordinate Digest Memory) (target : Coordinate) :
+    target ∈ (FtsGuessSigning.completedState environment secrets record state).retired ↔
+      target ∈ state.retired ∨ ∃ signature view,
+        (completePublicSigningRecord (FtsGuessSigning.secretTable.symm secrets) record).1.1 = some signature ∧
+        record.1.2 = some view ∧ view.1 = target.1 ∧ view.2 target.2.1 = target.2.2 := by
+  rcases record with ⟨⟨plan, view⟩, trace⟩
+  cases plan with
+  | none =>
+      cases view <;> simp only [FtsGuessSigning.completedState, completePublicSigningRecord, Option.map_none,
+        reduceCtorEq, false_and, exists_false, or_false]
+  | some plan =>
+      cases view with
+      | none => simp only [FtsGuessSigning.completedState, completePublicSigningRecord, reduceCtorEq, false_and, exists_false, or_false]
+      | some view =>
+          simp only [FtsGuessSigning.completedState, SecretGuessObservation.disclosureSequenceState, disclosureList_retired]
+          simp only [completePublicSigningRecord, Option.map_some, Option.some.injEq]
+          apply or_congr_right
+          constructor
+          · intro h
+            obtain ⟨tree, ht⟩ := List.mem_ofFn.mp h
+            refine ⟨_, view, rfl, rfl, congrArg Prod.fst ht, ?_⟩
+            have htree := congrArg (fun coordinate : Coordinate => coordinate.2.1) ht
+            simpa only [← htree] using congrArg (fun coordinate : Coordinate => coordinate.2.2) ht
+          · rintro ⟨signature, selected, _, rfl, hi, hl⟩
+            apply List.mem_ofFn.mpr
+            exact ⟨target.2.1, Prod.ext hi (Prod.ext rfl hl)⟩
+
+theorem fixed_signingProgram_tracking (environment : Environment Auxiliary Coordinate Digest Memory) (key : SecretKey)
+    (f : QueryImpl HashSpec Id) (message : Message) (state : State Coordinate Digest Memory)
+    (result : ((Option Signature × Option FewTimeView) × SigningBoundaryTrace) × State Coordinate Digest Memory)
+    (hr : fixedRun environment (FtsGuessSigning.secretTable key.ftsSecret) (signingProgram message) state result ≠ 0)
+    (hview : ∀ signature, result.1.1.1 = some signature →
+      result.1.1.2 = some (RetainedResidual.signingView key f message signature)) :
+    Tracking key f state result.2 [⟨message, result.1.1.1⟩] 1 := by
+  rw [signingProgram, fixedRun, runWith_bind, RetainedObservation.bind_nonzero] at hr
+  obtain ⟨middle, hm, hr⟩ := hr
+  change PublicSigningRecord × State Coordinate Digest Memory at middle
+  have hbase := fixed_auxiliary_tracking environment _ key f (.inr message) state middle hm
+  change fixedRun environment _ (FtsGuessSigning.completeRecord middle.1) middle.2 result ≠ 0 at hr
+  rw [FtsGuessSigning.fixedRun_completeRecord] at hr
+  simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+  subst result
+  change Tracking key f state
+    (FtsGuessSigning.completedState environment (FtsGuessSigning.secretTable key.ftsSecret) middle.1 middle.2)
+    [⟨message, (completePublicSigningRecord key.ftsSecret middle.1).1.1⟩] 1
+  change ∀ signature, (completePublicSigningRecord key.ftsSecret middle.1).1.1 = some signature →
+    (completePublicSigningRecord key.ftsSecret middle.1).1.2 = some (RetainedResidual.signingView key f message signature) at hview
+  have hcounts := congrArg Prod.fst (FtsGuessSigning.completedState_counts environment (FtsGuessSigning.secretTable key.ftsSecret) middle.1 middle.2)
+  dsimp only at hcounts
+  have hview_eq : (completePublicSigningRecord key.ftsSecret middle.1).1.2 = middle.1.1.2 := by
+    rcases middle.1 with ⟨⟨plan, view⟩, trace⟩
+    cases view <;> rfl
+  refine ⟨?_, ?_, ?_, ?_⟩
+  · rw [hcounts]; exact hbase.guesses
+  · intro target h
+    exact (completedState_retired environment _ middle.1 middle.2 target).mpr (Or.inl (hbase.retired h))
+  · intro target h
+    rcases (completedState_retired environment _ middle.1 middle.2 target).mp h with h | ⟨signature, view, hs, hv, hi, hl⟩
+    · rcases hbase.origin target h with h | h | h
+      · exact Or.inl h
+      · right; left; rwa [hcounts]
+      · obtain ⟨_, _, h, _⟩ := h; cases h
+    · right; right
+      change (completePublicSigningRecord key.ftsSecret middle.1).1.1 = some signature at hs
+      have hselected := hview signature hs
+      rw [hview_eq, hv] at hselected
+      have heq := Option.some.inj hselected
+      refine ⟨message, signature, ?_, ?_, ?_⟩
+      · rw [hs]; exact List.mem_singleton_self _
+      · simpa only [← heq] using hi
+      · simpa only [← heq] using hl
+  · intro target h
+    cases h
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessWitness.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessWitness.lean
new file mode 100644
index 000000000..735918b0d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessWitness.lean
@@ -0,0 +1,147 @@
+import SphincsSecurity.Proof.Forced.FtsGuessTracking
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec OtsContactTrace
+open FtsGuessSigning (Coordinate)
+open SecretGuessObservation (State Environment fixedRun fixedImpl runWith)
+set_option backward.isDefEq.respectTransparency false
+
+variable {Memory : Type}
+
+private theorem map_nonzero {First Result : Type} (function : First → Result) (law : SPMF First) (result : Result) :
+    (function <$> law) result ≠ 0 ↔ ∃ first, law first ≠ 0 ∧ result = function first := by
+  simp only [map_eq_bind_pure_comp, RetainedObservation.bind_nonzero, Function.comp_def,
+    ne_eq, SPMF.pure_apply_eq_zero_iff, not_not]
+
+private theorem logged_query_bind {Result : Type} (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Result) :
+    OtsPrefix.logged (liftM ((OracleWorld + SigningSpec).query input) >>= next) =
+      liftM ((OracleWorld + SigningSpec).query input) >>= fun answer =>
+        (fun tail => (tail.1, signingLogFragment input answer ++ tail.2)) <$> OtsPrefix.logged (next answer) := by
+  simp only [OtsPrefix.logged, OtsProbeSimulation.simulateQ_withTraceAppend_run_eq_signingTraceComputation,
+    simulateQ_id', OtsProbeSimulation.signingTraceComputation_query_bind]
+
+private theorem adversaryRun_pure {Result : Type} (parameter : PublicParameter) (labels : CanonicalGraphLabels) (result : Result) :
+    adversaryRun parameter labels (pure result) = pure (((result, []), 1), 1) := by
+  simp only [adversaryRun, OtsPrefix.logged, simulateQ_pure, WriterT.run_pure]
+  rfl
+
+private theorem adversaryRun_query_bind {Result : Type} (parameter : PublicParameter) (labels : CanonicalGraphLabels)
+    (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Result) :
+    adversaryRun parameter labels (liftM ((OracleWorld + SigningSpec).query input) >>= next) = (do
+      let head ← ((adversaryImpl parameter labels input).run).run
+      let tail ← adversaryRun parameter labels (next head.1.1)
+      pure (((tail.1.1.1, signingLogFragment input head.1.1 ++ tail.1.1.2), head.1.2 * tail.1.2), head.2 * tail.2)) := by
+  simp only [adversaryRun, logged_query_bind, simulateQ_bind, simulateQ_spec_query, simulateQ_map,
+    WriterT.run_bind, WriterT.run_map, Functor.map_map, bind_pure_comp]
+
+theorem fixed_adversaryRun_tracking (environment : Environment Auxiliary Coordinate Digest Memory) (key : SecretKey)
+    (f : QueryImpl HashSpec Id) (labels : CanonicalGraphLabels)
+    (hsigning : ∀ message state result,
+      fixedRun environment (FtsGuessSigning.secretTable key.ftsSecret) (signingProgram message) state result ≠ 0 →
+      ∀ signature, result.1.1.1 = some signature →
+        result.1.1.2 = some (RetainedResidual.signingView key f message signature))
+    {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result) (state : State Coordinate Digest Memory)
+    (result : (((Result × QueryLog SigningSpec) × SigningBoundaryTrace) × Trace) × State Coordinate Digest Memory)
+    (hr : fixedRun environment (FtsGuessSigning.secretTable key.ftsSecret) (adversaryRun key.parameter labels computation) state result ≠ 0) :
+    Tracking key f state result.2 result.1.1.1.2 result.1.2 := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      simp only [adversaryRun_pure, fixedRun, SecretGuessObservation.runWith_pure,
+        ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+      subst result
+      exact Tracking.refl key f state
+  | query_bind input next ih =>
+      simp only [adversaryRun_query_bind, fixedRun, runWith_bind, SecretGuessObservation.runWith_pure,
+        RetainedObservation.bind_nonzero, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+      obtain ⟨head, hh, tail, ht, rfl⟩ := hr
+      have hhead : Tracking key f state head.2 (signingLogFragment input head.1.1.1) head.1.2 := by
+        cases input with
+        | inl input =>
+            simp only [adversaryImpl, WriterT.run_mk, runWith_map, map_nonzero] at hh
+            obtain ⟨answer, ha, rfl⟩ := hh
+            exact fixed_worldProgram_tracking environment key f labels input state answer ha
+        | inr message =>
+            simp only [adversaryImpl, WriterT.run_mk, runWith_map, map_nonzero] at hh
+            obtain ⟨record, hr, rfl⟩ := hh
+            exact fixed_signingProgram_tracking environment key f message state record hr (hsigning message state record hr)
+      exact hhead.trans (ih head.1.1.1 head.2 tail ht)
+
+private theorem traced_map {First Result : Type} (function : First → Result) (computation : OracleComp OracleWorld First) :
+    QueryPause.traced hashObservationTrace (function <$> computation) =
+      (fun result => (function result.1, result.2)) <$> QueryPause.traced hashObservationTrace computation := by
+  simp only [QueryPause.traced, simulateQ_map, WriterT.run_map]
+
+theorem fixed_tracedBoundary_tracking (environment : Environment Auxiliary Coordinate Digest Memory) (key : SecretKey)
+    (f : QueryImpl HashSpec Id) (labels : CanonicalGraphLabels)
+    {Result : Type} (computation : OracleComp OracleWorld Result) (state : State Coordinate Digest Memory)
+    (result : ((Result × SigningBoundaryTrace) × Trace) × State Coordinate Digest Memory)
+    (hr : fixedRun environment (FtsGuessSigning.secretTable key.ftsSecret) (simulateQ (worldProgram key.parameter labels)
+      (QueryPause.traced hashObservationTrace (boundaryComputation key.parameter computation))) state result ≠ 0) :
+    Tracking key f state result.2 [] result.1.2 := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      simp only [boundaryComputation, simulateQ_pure, WriterT.run_pure, QueryPause.traced_pure,
+        fixedRun, SecretGuessObservation.runWith_pure, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+      subst result
+      exact Tracking.refl key f state
+  | query_bind input next ih =>
+      simp only [ResidualByteFrontend.boundaryComputation_query_bind, QueryPause.traced_query_bind, traced_map,
+        simulateQ_bind, simulateQ_spec_query, simulateQ_map, fixedRun, runWith_bind, runWith_map,
+        RetainedObservation.bind_nonzero, map_nonzero] at hr
+      obtain ⟨middle, hm, outer, ⟨tail, ht, rfl⟩, rfl⟩ := hr
+      exact (fixed_worldProgram_tracking environment key f labels input state middle hm).trans
+        (ih middle.1 middle.2 tail ht)
+
+theorem fixed_completedRun_tracking (environment : Environment Auxiliary Coordinate Digest Memory) (key : SecretKey)
+    (f : QueryImpl HashSpec Id) (labels : CanonicalGraphLabels)
+    (hsigning : ∀ message state result,
+      fixedRun environment (FtsGuessSigning.secretTable key.ftsSecret) (signingProgram message) state result ≠ 0 →
+      ∀ signature, result.1.1.1 = some signature →
+        result.1.1.2 = some (RetainedResidual.signingView key f message signature))
+    (adversary : Adversary) (state : State Coordinate Digest Memory) (result : Completed × State Coordinate Digest Memory)
+    (hr : fixedRun environment (FtsGuessSigning.secretTable key.ftsSecret)
+      (completedRun key.parameter key.root labels adversary) state result ≠ 0) :
+    Tracking key f state result.2 result.1.1.1.1.2 (result.1.1.2 * result.1.2.2) := by
+  simp only [completedRun, fixedRun, runWith_bind, SecretGuessObservation.runWith_pure,
+    RetainedObservation.bind_nonzero, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+  obtain ⟨before, hb, checked, hc, rfl⟩ := hr
+  have hbefore := fixed_adversaryRun_tracking environment key f labels hsigning _ state before hb
+  have hchecked := fixed_tracedBoundary_tracking environment key f labels _ before.2 checked hc
+  simpa only [List.append_nil] using hbefore.trans hchecked
+
+theorem Tracking.uncovered_guess {key : SecretKey} {f : QueryImpl HashSpec Id} {before after : State Coordinate Digest Memory}
+    {log : QueryLog SigningSpec} {trace : Trace} (tracking : Tracking key f before after log trace)
+    (target : FewTimeView) (tree : FtsTree) (hinitial : (target.1, tree, target.2 tree) ∉ before.retired)
+    (hcovered : ¬ReferenceFtsCoverage.CoveredByLog key f log target tree)
+    (hquery : FtsVerifierWitness.TrueSecretQuery f key target.1 tree (target.2 tree) trace) :
+    (target.1, tree, target.2 tree) ∈ after.guesses := by
+  rcases tracking.origin (target.1, tree, target.2 tree) (tracking.queried _ hquery) with h | h | h
+  · exact (hinitial h).elim
+  · exact h
+  · exact (hcovered h).elim
+
+theorem Tracking.two_guesses {key : SecretKey} {f : QueryImpl HashSpec Id} {before after : State Coordinate Digest Memory}
+    {log : QueryLog SigningSpec} {trace : Trace} (tracking : Tracking key f before after log trace)
+    (hinitial : before.retired = ∅) (forgery : Forgery) (h : ReferenceFtsCoverage.TwoGuesses key f log trace forgery) :
+    2 ≤ after.guesses.card := by
+  obtain ⟨first, second, hne, hf, hqf, hs, hqs⟩ := h
+  let target := RetainedResidual.signingView key f forgery.message forgery.signature
+  have hf := tracking.uncovered_guess target first (by rw [hinitial]; exact Finset.notMem_empty _) hf hqf
+  have hs := tracking.uncovered_guess target second (by rw [hinitial]; exact Finset.notMem_empty _) hs hqs
+  exact Finset.one_lt_card.mpr ⟨_, hf, _, hs, fun he => hne (congrArg (fun c : Coordinate => c.2.1) he)⟩
+
+theorem Tracking.near_guess {key : SecretKey} {f : QueryImpl HashSpec Id} {before after : State Coordinate Digest Memory}
+    {log : QueryLog SigningSpec} {trace : Trace} (tracking : Tracking key f before after log trace)
+    (hinitial : before.retired = ∅) (boundary : SigningBoundaryTrace) (forgery : Forgery)
+    (h : ReferenceFtsCoverage.NearGuess key f log boundary trace forgery) :
+    let target := RetainedResidual.signingView key f forgery.message forgery.signature
+    ∃ omitted, TargetCertificateAt key (Finset.univ.erase omitted)
+      (ReferenceFtsCoverage.transcriptCache f boundary trace, log) (RetainedResidual.signingInput key forgery.message forgery.signature) ∧
+      (target.1, omitted, target.2 omitted) ∈ after.guesses := by
+  obtain ⟨omitted, hcertificate, hcovered, hquery⟩ := h
+  exact ⟨omitted, hcertificate, tracking.uncovered_guess _ omitted
+    (by rw [hinitial]; exact Finset.notMem_empty _) hcovered hquery⟩
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessWork.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessWork.lean
new file mode 100644
index 000000000..2ad05c991
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/FtsGuessWork.lean
@@ -0,0 +1,183 @@
+import SphincsSecurity.Proof.Forced.FtsGuessReference
+namespace SphincsSecurity.Concrete.FtsGuessHash
+
+open _root_.OracleComp OracleSpec OtsContactTrace
+open FtsGuessSigning (Coordinate)
+open SecretGuessObservation (State Environment fixedRun fixedImpl runWith)
+set_option backward.isDefEq.respectTransparency false
+
+variable {Memory : Type}
+
+theorem runWith_bind {First Result : Type}
+    (implementation : QueryImpl World (StateT (State Coordinate Digest Memory) SPMF))
+    (first : OracleComp World First) (next : First → OracleComp World Result) (state : State Coordinate Digest Memory) :
+    runWith implementation (first >>= next) state =
+      runWith implementation first state >>= fun middle => runWith implementation (next middle.1) middle.2 := by
+  simp only [runWith, simulateQ_bind, StateT.run_bind]
+
+theorem runWith_map {First Result : Type}
+    (implementation : QueryImpl World (StateT (State Coordinate Digest Memory) SPMF))
+    (function : First → Result) (computation : OracleComp World First) (state : State Coordinate Digest Memory) :
+    runWith implementation (function <$> computation) state =
+      (fun result => (function result.1, result.2)) <$> runWith implementation computation state := by
+  simp only [runWith, simulateQ_map, StateT.run_map]
+
+private theorem map_nonzero {First Result : Type} (function : First → Result) (law : SPMF First) (result : Result) :
+    (function <$> law) result ≠ 0 ↔ ∃ first, law first ≠ 0 ∧ result = function first := by
+  simp only [map_eq_bind_pure_comp, RetainedObservation.bind_nonzero, Function.comp_def,
+    ne_eq, SPMF.pure_apply_eq_zero_iff, not_not]
+
+theorem fixed_auxiliary_probes (environment : Environment Auxiliary Coordinate Digest Memory) (secrets : Coordinate → Digest)
+    (input : Auxiliary.Domain) (state : State Coordinate Digest Memory) (result : Auxiliary.Range input × State Coordinate Digest Memory)
+    (hr : fixedRun environment secrets (liftM (World.query (.inl input))) state result ≠ 0) :
+    result.2.probes = state.probes := by
+  simp only [fixedRun, runWith, simulateQ_spec_query, fixedImpl, StateT.run_mk, map_nonzero] at hr
+  obtain ⟨answer, _, rfl⟩ := hr
+  rfl
+
+theorem fixed_hashProgram_probes (environment : Environment Auxiliary Coordinate Digest Memory) (secrets : Coordinate → Digest)
+    (parameter : PublicParameter) (labels : CanonicalGraphLabels) (input : HashInput)
+    (state : State Coordinate Digest Memory) (result : HashOutput × State Coordinate Digest Memory)
+    (hr : fixedRun environment secrets (hashProgram parameter labels input) state result ≠ 0) :
+    result.2.probes ≤ state.probes + 1 := by
+  cases hd : FtsProbeSimulation.decodeProbe? parameter input with
+  | none =>
+      rw [hashProgram, hd] at hr
+      rw [fixed_auxiliary_probes environment secrets (.inl (.inr input)) state result hr]
+      omega
+  | some probe =>
+      rw [hashProgram, hd, fixedRun, SecretGuessObservation.runWith_query_bind] at hr
+      simp only [fixedImpl, StateT.run_mk, pure_bind] at hr
+      split at hr
+      · simp only [SecretGuessObservation.runWith_pure, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+        subst result
+        exact le_rfl
+      · have heq := fixed_auxiliary_probes environment secrets (.inl (.inr input)) _ result hr
+        simpa only [SecretGuessObservation.afterTrial] using heq.le
+
+theorem fixed_worldProgram_probes (environment : Environment Auxiliary Coordinate Digest Memory) (secrets : Coordinate → Digest)
+    (parameter : PublicParameter) (labels : CanonicalGraphLabels) (input : OracleWorld.Domain)
+    (state : State Coordinate Digest Memory) (result : OracleWorld.Range input × State Coordinate Digest Memory)
+    (hr : fixedRun environment secrets (worldProgram parameter labels input) state result ≠ 0) :
+    result.2.probes ≤ state.probes + (signingBoundaryTrace parameter input result.1).hashCalls := by
+  rw [signingBoundaryTrace_hashCalls_eq]
+  cases input with
+  | inl input =>
+      rw [fixed_auxiliary_probes environment secrets (.inl (.inl input)) state result hr]
+      exact le_rfl
+  | inr input => exact fixed_hashProgram_probes environment secrets parameter labels input state result hr
+
+theorem fixed_signingProgram_probes (environment : Environment Auxiliary Coordinate Digest Memory) (secrets : Coordinate → Digest)
+    (message : Message) (state : State Coordinate Digest Memory)
+    (result : ((Option Signature × Option FewTimeView) × SigningBoundaryTrace) × State Coordinate Digest Memory)
+    (hr : fixedRun environment secrets (signingProgram message) state result ≠ 0) :
+    result.2.probes = state.probes := by
+  rw [signingProgram, fixedRun, runWith_bind, RetainedObservation.bind_nonzero] at hr
+  obtain ⟨middle, hm, hr⟩ := hr
+  have hp := fixed_auxiliary_probes environment secrets (.inr message) state middle hm
+  change fixedRun environment secrets (FtsGuessSigning.completeRecord middle.1) middle.2 result ≠ 0 at hr
+  rw [FtsGuessSigning.fixedRun_completeRecord] at hr
+  simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+  subst result
+  exact (congrArg Prod.snd (FtsGuessSigning.completedState_counts environment secrets middle.1 middle.2)).trans hp
+
+private theorem two_writers_probes {Source Result ω₁ ω₂ : Type} {spec : OracleSpec Source} [Monoid ω₁] [Monoid ω₂]
+    (environment : Environment Auxiliary Coordinate Digest Memory) (secrets : Coordinate → Digest)
+    (implementation : QueryImpl spec (WriterT ω₁ (WriterT ω₂ (OracleComp World))))
+    (cost : ω₁ → Nat) (hzero : cost 1 = 0) (hmul : ∀ first second, cost (first * second) = cost first + cost second)
+    (hquery : ∀ input state result, fixedRun environment secrets ((implementation input).run).run state result ≠ 0 →
+      result.2.probes ≤ state.probes + cost result.1.1.2)
+    (computation : OracleComp spec Result) (state : State Coordinate Digest Memory)
+    (result : ((Result × ω₁) × ω₂) × State Coordinate Digest Memory)
+    (hr : fixedRun environment secrets ((simulateQ implementation computation).run).run state result ≠ 0) :
+    result.2.probes ≤ state.probes + cost result.1.1.2 := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      simp only [simulateQ_pure, WriterT.run_pure, fixedRun, SecretGuessObservation.runWith_pure,
+        ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+      subst result
+      simp only [hzero, Nat.add_zero, le_refl]
+  | query_bind input next ih =>
+      simp only [simulateQ_bind, simulateQ_spec_query, WriterT.run_bind, WriterT.run_map,
+        fixedRun, runWith_bind, runWith_map, RetainedObservation.bind_nonzero, map_nonzero] at hr
+      obtain ⟨middle, hm, outer, ⟨tail, ht, rfl⟩, rfl⟩ := hr
+      have hhead := hquery input state middle hm
+      have htail := ih middle.1.1.1 middle.2 tail ht
+      simp only [hmul]
+      omega
+
+theorem fixed_adversaryRun_probes {Result : Type} (environment : Environment Auxiliary Coordinate Digest Memory)
+    (secrets : Coordinate → Digest) (parameter : PublicParameter) (labels : CanonicalGraphLabels)
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) (state : State Coordinate Digest Memory)
+    (result : (((Result × QueryLog SigningSpec) × SigningBoundaryTrace) × Trace) × State Coordinate Digest Memory)
+    (hr : fixedRun environment secrets (adversaryRun parameter labels computation) state result ≠ 0) :
+    result.2.probes ≤ state.probes + result.1.1.2.hashCalls := by
+  apply two_writers_probes environment secrets (adversaryImpl parameter labels) SigningBoundaryTrace.hashCalls rfl
+    SigningBoundaryTrace.hashCalls_mul _ (OtsPrefix.logged computation) state result hr
+  intro input state result hr
+  cases input with
+  | inl input =>
+      simp only [adversaryImpl, WriterT.run_mk, fixedRun, runWith_map, map_nonzero] at hr
+      obtain ⟨answer, ha, rfl⟩ := hr
+      exact fixed_worldProgram_probes environment secrets parameter labels input state answer ha
+  | inr message =>
+      simp only [adversaryImpl, WriterT.run_mk, fixedRun, runWith_map, map_nonzero] at hr
+      obtain ⟨record, hr, rfl⟩ := hr
+      rw [fixed_signingProgram_probes environment secrets message state record hr]
+      exact Nat.le_add_right _ _
+
+private theorem traced_map {First Result : Type} (function : First → Result) (computation : OracleComp OracleWorld First) :
+    QueryPause.traced hashObservationTrace (function <$> computation) =
+      (fun result => (function result.1, result.2)) <$> QueryPause.traced hashObservationTrace computation := by
+  simp only [QueryPause.traced, simulateQ_map, WriterT.run_map]
+
+theorem fixed_tracedBoundary_probes {Result : Type} (environment : Environment Auxiliary Coordinate Digest Memory)
+    (secrets : Coordinate → Digest) (parameter : PublicParameter) (labels : CanonicalGraphLabels)
+    (computation : OracleComp OracleWorld Result) (state : State Coordinate Digest Memory)
+    (result : ((Result × SigningBoundaryTrace) × Trace) × State Coordinate Digest Memory)
+    (hr : fixedRun environment secrets (simulateQ (worldProgram parameter labels)
+      (QueryPause.traced hashObservationTrace (boundaryComputation parameter computation))) state result ≠ 0) :
+    result.2.probes ≤ state.probes + result.1.1.2.hashCalls := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      simp only [boundaryComputation, simulateQ_pure, WriterT.run_pure, QueryPause.traced_pure,
+        fixedRun, SecretGuessObservation.runWith_pure, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+      subst result
+      exact le_rfl
+  | query_bind input next ih =>
+      simp only [ResidualByteFrontend.boundaryComputation_query_bind, QueryPause.traced_query_bind, traced_map,
+        simulateQ_bind, simulateQ_spec_query, simulateQ_map, fixedRun, runWith_bind, runWith_map,
+        RetainedObservation.bind_nonzero, map_nonzero] at hr
+      obtain ⟨middle, hm, outer, ⟨tail, ht, rfl⟩, rfl⟩ := hr
+      have hhead := fixed_worldProgram_probes environment secrets parameter labels input state middle hm
+      have htail := ih middle.1 middle.2 tail ht
+      simp only [SigningBoundaryTrace.hashCalls_mul]
+      omega
+
+theorem fixed_verifyProgram_probes (environment : Environment Auxiliary Coordinate Digest Memory)
+    (secrets : Coordinate → Digest) (parameter : PublicParameter) (root : Digest) (labels : CanonicalGraphLabels)
+    (forgery : Forgery) (state : State Coordinate Digest Memory)
+    (result : ((Bool × SigningBoundaryTrace) × Trace) × State Coordinate Digest Memory)
+    (hr : fixedRun environment secrets (verifyProgram parameter root labels forgery) state result ≠ 0) :
+    result.2.probes ≤ state.probes + result.1.1.2.hashCalls :=
+  fixed_tracedBoundary_probes environment secrets parameter labels _ state result hr
+
+abbrev Completed := AdversaryTrace × (Bool × SigningBoundaryTrace) × Trace
+
+def completedWork (result : Completed) : Nat :=
+  result.1.1.2.hashCalls + result.2.1.2.hashCalls
+
+theorem fixed_completedRun_probes (environment : Environment Auxiliary Coordinate Digest Memory)
+    (secrets : Coordinate → Digest) (parameter : PublicParameter) (root : Digest) (labels : CanonicalGraphLabels)
+    (adversary : Adversary) (state : State Coordinate Digest Memory) (result : Completed × State Coordinate Digest Memory)
+    (hr : fixedRun environment secrets (completedRun parameter root labels adversary) state result ≠ 0) :
+    result.2.probes ≤ state.probes + completedWork result.1 := by
+  simp only [completedRun, fixedRun, runWith_bind, SecretGuessObservation.runWith_pure,
+    RetainedObservation.bind_nonzero, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+  obtain ⟨before, hb, checked, hc, rfl⟩ := hr
+  have hbefore := fixed_adversaryRun_probes environment secrets parameter labels _ state before hb
+  have hchecked := fixed_verifyProgram_probes environment secrets parameter root labels _ before.2 checked hc
+  simp only [completedWork]
+  omega
+
+end SphincsSecurity.Concrete.FtsGuessHash
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessErasure.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessErasure.lean
new file mode 100644
index 000000000..37b409c25
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessErasure.lean
@@ -0,0 +1,71 @@
+import SphincsSecurity.Proof.Forced.SecretGuessObservation
+namespace SphincsSecurity.Concrete.SecretGuessObservation
+
+open _root_.OracleComp OracleSpec UniformTableCompletion
+set_option backward.isDefEq.respectTransparency false
+
+variable {Coordinate Value AuxIndex : Type} {auxSpec : OracleSpec AuxIndex}
+  [Fintype Coordinate] [DecidableEq Coordinate] [DecidableEq Value]
+
+noncomputable def fixedAnswers (auxiliary : QueryImpl auxSpec ProbComp) (labels : Coordinate → Value) :
+    QueryImpl (World auxSpec Coordinate Value) ProbComp
+  | .inl input => auxiliary input
+  | .inr (.inl (coordinate, candidate)) => pure (decide (labels coordinate = candidate))
+  | .inr (.inr coordinate) => pure (labels coordinate)
+
+noncomputable def environment (auxiliary : QueryImpl auxSpec ProbComp) : Environment auxSpec Coordinate Value PUnit where
+  auxiliary _ input := (fun answer => (answer, PUnit.unit)) <$> (liftM (auxiliary input) : PMF _)
+  trial _ _ _ _ := PUnit.unit
+  disclosure _ _ _ := PUnit.unit
+
+omit [Fintype Coordinate] [DecidableEq Coordinate] in
+theorem fixedAnswers_disclosureSequence (auxiliary : QueryImpl auxSpec ProbComp) (labels : Coordinate → Value)
+    {n : Nat} (coordinates : Fin n → Coordinate) :
+    simulateQ (fixedAnswers auxiliary labels) (sequenceFin fun position => disclosure (coordinates position)) =
+      pure (fun position => labels (coordinates position)) := by
+  induction n with
+  | zero =>
+      simp only [sequenceFin, simulateQ_pure]
+      congr 1
+      funext position
+      exact Fin.elim0 position
+  | succ n ih =>
+      rw [sequenceFin, simulateQ_bind]
+      change (pure (labels (coordinates 0)) >>= _) = _
+      rw [pure_bind, simulateQ_bind, ih]
+      simp only [pure_bind, simulateQ_pure]
+      congr 1
+      funext position
+      exact Fin.cases rfl (fun _ => rfl) position
+
+omit [Fintype Coordinate] in
+theorem fixedImpl_projection (auxiliary : QueryImpl auxSpec ProbComp) (labels : Coordinate → Value)
+    (input : (World auxSpec Coordinate Value).Domain) (state : State Coordinate Value PUnit) :
+    Prod.fst <$> ((fixedImpl (environment auxiliary) labels input).run state) = 𝒟[fixedAnswers auxiliary labels input] := by
+  cases input with
+  | inl input =>
+      change Prod.fst <$> ((fun result => (result.1, { state with memory := result.2 })) <$>
+        𝒟[(fun answer => (answer, PUnit.unit)) <$> (liftM (auxiliary input) : PMF _)]) = 𝒟[auxiliary input]
+      simp only [evalDist_map, Functor.map_map, id_map']
+      rfl
+  | inr input =>
+      cases input <;> simp only [fixedImpl, fixedAnswers, StateT.run_mk, map_pure, evalDist_pure]
+
+omit [Fintype Coordinate] in
+theorem fixedRun_projection {Result : Type} (auxiliary : QueryImpl auxSpec ProbComp) (labels : Coordinate → Value)
+    (computation : OracleComp (World auxSpec Coordinate Value) Result) (state : State Coordinate Value PUnit) :
+    Prod.fst <$> fixedRun (environment auxiliary) labels computation state =
+      𝒟[simulateQ (fixedAnswers auxiliary labels) computation] := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure result => simp only [fixedRun, runWith_pure, map_pure, simulateQ_pure, evalDist_pure]
+  | query_bind input next ih =>
+      simp only [fixedRun, runWith_query_bind, map_bind, simulateQ_bind, simulateQ_spec_query, evalDist_bind]
+      change ((fixedImpl (environment auxiliary) labels input).run state >>= fun middle =>
+        Prod.fst <$> fixedRun (environment auxiliary) labels (next middle.1) middle.2) = _
+      simp only [ih]
+      have h := congrArg (· >>= fun answer => 𝒟[simulateQ (fixedAnswers auxiliary labels) (next answer)])
+        (fixedImpl_projection auxiliary labels input state)
+      rw [bind_map_left] at h
+      exact h
+
+end SphincsSecurity.Concrete.SecretGuessObservation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessForceBound.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessForceBound.lean
new file mode 100644
index 000000000..b4d317c6c
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessForceBound.lean
@@ -0,0 +1,115 @@
+import SphincsSecurity.Proof.Forced.SecretGuessForceLikelihood
+namespace SphincsSecurity.Concrete.SecretGuessObservation
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+variable {Coordinate Value Memory AuxIndex : Type} {auxSpec : OracleSpec AuxIndex}
+  [Fintype Coordinate] [DecidableEq Coordinate] [DecidableEq Value]
+
+theorem forceFactor_le_one (slot : Nat) (state : State Coordinate Value Memory)
+    (input : (World auxSpec Coordinate Value).Domain) : forceFactor slot state input ≤ 1 := by
+  cases input with
+  | inl input => exact le_rfl
+  | inr input =>
+      cases input with
+      | inl probe =>
+          rcases probe with ⟨coordinate, candidate⟩
+          simp only [forceFactor, trialFactor]
+          split
+          · split
+            · simpa only [SPMF.probOutput_eq_apply] using
+                (show Pr[= true | trial state.allowed coordinate candidate] ≤ 1 from probOutput_le_one)
+            · exact bot_le
+          · exact le_rfl
+      | inr coordinate => exact le_rfl
+
+theorem forceFactor_weight_bound (environment : Environment auxSpec Coordinate Value Memory) (size budget slot : Nat)
+    (hslot : slot ≤ budget) (state : State Coordinate Value Memory) (weight : ENNReal)
+    (hs : Invariant size state) (ha : ∀ coordinate, (state.allowed coordinate).Nonempty)
+    (hw : weight ≤ 1) (hlate : slot < state.probes → weight ≤ ((size - budget : Nat) : ENNReal)⁻¹)
+    (input : (World auxSpec Coordinate Value).Domain)
+    (result : (World auxSpec Coordinate Value).Range input × State Coordinate Value Memory)
+    (hr : (forcedImpl environment slot input).run state result ≠ 0) :
+    weight * forceFactor slot state input ≤ 1 ∧
+      (slot < result.2.probes → weight * forceFactor slot state input ≤ ((size - budget : Nat) : ENNReal)⁻¹) := by
+  have hm : weight * forceFactor slot state input ≤ weight := mul_le_of_le_one_right' (forceFactor_le_one slot state input)
+  refine ⟨hm.trans hw, ?_⟩
+  intro hafter
+  by_cases hb : slot < state.probes
+  · exact hm.trans (hlate hb)
+  have hp := forcedImpl_probes environment slot state input result hr
+  cases input with
+  | inl input => simp only [probeStep, Nat.add_zero] at hp; omega
+  | inr input =>
+      cases input with
+      | inl probe =>
+          rcases probe with ⟨coordinate, candidate⟩
+          change result.2.probes = state.probes + 1 at hp
+          have he : state.probes = slot := by omega
+          simp only [forceFactor, trialFactor, if_pos he]
+          split
+          next hc =>
+            exact (mul_le_of_le_one_left' hw).trans
+              (trial_true_le size budget state hs ha (he ▸ hslot) coordinate hc candidate)
+          next hc => simp only [mul_zero]; exact bot_le
+      | inr coordinate => simp only [probeStep, Nat.add_zero] at hp; omega
+
+theorem weightedForcedRun_weight_bound [Fintype Value] [Nonempty Value] {Result : Type}
+    (environment : Environment auxSpec Coordinate Value Memory) (budget slot : Nat) (hslot : slot ≤ budget)
+    (computation : OracleComp (World auxSpec Coordinate Value) Result) (memory : Memory)
+    (result : Result × State Coordinate Value Memory × ENNReal)
+    (hr : WeightedQuery.run (forcedImpl environment slot) (forceFactor slot) computation (initialState memory, 1) result ≠ 0) :
+    forceWeight slot result.2 ≤ ((Fintype.card Value - budget : Nat) : ENNReal)⁻¹ := by
+  let valid (state : State Coordinate Value Memory × ENNReal) : Prop :=
+    Invariant (Fintype.card Value) state.1 ∧ (∀ coordinate, (state.1.allowed coordinate).Nonempty) ∧
+      state.2 ≤ 1 ∧ (slot < state.1.probes → state.2 ≤ ((Fintype.card Value - budget : Nat) : ENNReal)⁻¹)
+  have hstep (state : State Coordinate Value Memory × ENNReal) (hs : valid state)
+      (input : (World auxSpec Coordinate Value).Domain)
+      (middle : (World auxSpec Coordinate Value).Range input × State Coordinate Value Memory)
+      (hm : (forcedImpl environment slot input).run state.1 middle ≠ 0) :
+      valid (middle.2, state.2 * forceFactor slot state.1 input) := by
+    have hlazy : lazyRun environment (liftM ((World auxSpec Coordinate Value).query input)) state.1 middle ≠ 0 := by
+      simpa only [lazyRun, runWith, simulateQ_spec_query] using forcedImpl_nonzero environment slot state.1 input middle hm
+    exact ⟨lazyRun_invariant environment (Fintype.card Value) _ state.1 hs.1 middle hlazy,
+      lazyRun_nonempty environment _ state.1 hs.2.1 middle hlazy,
+      forceFactor_weight_bound environment (Fintype.card Value) budget slot hslot state.1 state.2 hs.1 hs.2.1
+        hs.2.2.1 hs.2.2.2 input middle hm⟩
+  have hinitial : valid (initialState memory, 1) :=
+    ⟨initialState_invariant memory, fun _ => Finset.univ_nonempty, le_rfl, fun h => False.elim (Nat.not_lt_zero _ h)⟩
+  have h := WeightedQuery.run_preserves (forcedImpl environment slot) (forceFactor slot) valid hstep
+    computation (initialState memory, 1) hinitial result hr
+  rw [forceWeight]
+  split
+  · exact h.2.2.2 ‹_›
+  · exact bot_le
+
+theorem hitRun_payoff_le_forced [Fintype Value] [Nonempty Value] {Result : Type}
+    (environment : Environment auxSpec Coordinate Value Memory) (budget slot : Nat) (hslot : slot ≤ budget)
+    (computation : OracleComp (World auxSpec Coordinate Value) Result) (memory : Memory)
+    (payoff : Result × State Coordinate Value Memory → ENNReal) :
+    (∑' result, Pr[= result | hitRun environment slot computation (initialState memory)] * payoff result) ≤
+      ((Fintype.card Value - budget : Nat) : ENNReal)⁻¹ *
+        (∑' result, Pr[= result | forcedRun environment slot computation (initialState memory)] * payoff result) := by
+  rw [hitRun_weighted_forced]
+  have hforget := congrArg (fun law : SPMF (Result × State Coordinate Value Memory) =>
+    ∑' result, Pr[= result | law] * payoff result)
+    (WeightedQuery.run_forget (forcedImpl environment slot) (forceFactor slot) computation (initialState memory, 1))
+  rw [tsum_probOutput_map_mul] at hforget
+  rw [← show (∑' result, Pr[= result | WeightedQuery.run (forcedImpl environment slot) (forceFactor slot)
+      computation (initialState memory, 1)] * payoff (result.1, result.2.1)) =
+      (∑' result, Pr[= result | forcedRun environment slot computation (initialState memory)] * payoff result) from hforget,
+    ← ENNReal.tsum_mul_left]
+  apply ENNReal.tsum_le_tsum
+  intro result
+  by_cases hz : WeightedQuery.run (forcedImpl environment slot) (forceFactor slot) computation (initialState memory, 1) result = 0
+  · simp only [SPMF.probOutput_eq_apply, hz, zero_mul, mul_zero, le_refl]
+  · calc
+      _ ≤ Pr[= result | WeightedQuery.run (forcedImpl environment slot) (forceFactor slot)
+          computation (initialState memory, 1)] *
+          (((Fintype.card Value - budget : Nat) : ENNReal)⁻¹ * payoff (result.1, result.2.1)) :=
+        mul_le_mul' le_rfl (mul_le_mul' (weightedForcedRun_weight_bound environment budget slot hslot computation memory result hz) le_rfl)
+      _ = _ := by ring
+
+end SphincsSecurity.Concrete.SecretGuessObservation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessForceLikelihood.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessForceLikelihood.lean
new file mode 100644
index 000000000..021f28dc6
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessForceLikelihood.lean
@@ -0,0 +1,122 @@
+import SphincsSecurity.Proof.Forced.SecretGuessForced
+import SphincsSecurity.Proof.Base.WeightedQuery
+namespace SphincsSecurity.Concrete.SecretGuessObservation
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+variable {Coordinate Value Memory AuxIndex : Type} {auxSpec : OracleSpec AuxIndex}
+  [Fintype Coordinate] [DecidableEq Coordinate] [DecidableEq Value]
+
+noncomputable def hitTrial (slot : Nat) (state : State Coordinate Value Memory)
+    (coordinate : Coordinate) (candidate : Value) : SPMF Bool :=
+  if state.probes = slot then
+    trial state.allowed coordinate candidate >>= fun hit =>
+      if hit = true ∧ coordinate ∉ state.retired then pure hit else failure
+  else trial state.allowed coordinate candidate
+
+noncomputable def trialFactor (slot : Nat) (state : State Coordinate Value Memory)
+    (coordinate : Coordinate) (candidate : Value) : ENNReal :=
+  if state.probes = slot then
+    if coordinate ∉ state.retired then trial state.allowed coordinate candidate true else 0
+  else 1
+
+theorem hitTrial_apply (slot : Nat) (state : State Coordinate Value Memory)
+    (coordinate : Coordinate) (candidate : Value) (hit : Bool) :
+    hitTrial slot state coordinate candidate hit =
+      trialFactor slot state coordinate candidate * forcedTrial slot state coordinate candidate hit := by
+  by_cases hs : state.probes = slot
+  · by_cases hc : coordinate ∉ state.retired
+    · have hmass : hitTrial slot state coordinate candidate hit =
+          if hit = true then trial state.allowed coordinate candidate true else 0 := by
+        rw [hitTrial, if_pos hs, SPMF.bind_apply_eq_tsum]
+        simp only [tsum_fintype, Fintype.sum_bool, Bool.false_eq_true, false_and, if_false, true_and,
+          hc, SPMF.failure_apply, mul_zero, add_zero]
+        split <;> simp_all
+      rw [hmass]
+      by_cases hp : trial state.allowed coordinate candidate true = 0
+      · simp only [trialFactor, if_pos hs, if_pos hc, hp, zero_mul, ite_self]
+      · have he : EligibleAt slot state coordinate candidate := ⟨hs, hc, hp⟩
+        simp only [trialFactor, if_pos hs, if_pos hc, forcedTrial, if_pos he, SPMF.pure_apply,
+          mul_ite, mul_one, mul_zero]
+    · simp only [hitTrial, trialFactor, if_pos hs, hc, and_false, if_false, SPMF.bind_apply_eq_tsum,
+        SPMF.failure_apply, mul_zero, tsum_zero, zero_mul]
+  · have he : ¬EligibleAt slot state coordinate candidate := fun h => hs h.1
+    simp only [hitTrial, trialFactor, if_neg hs, forcedTrial, if_neg he, one_mul]
+
+theorem hitTrial_bind_apply {Result : Type} (slot : Nat) (state : State Coordinate Value Memory)
+    (coordinate : Coordinate) (candidate : Value) (next : Bool → SPMF Result) (result : Result) :
+    (hitTrial slot state coordinate candidate >>= next) result =
+      trialFactor slot state coordinate candidate * (forcedTrial slot state coordinate candidate >>= next) result := by
+  simp only [SPMF.bind_apply_eq_tsum, hitTrial_apply, mul_assoc, ENNReal.tsum_mul_left]
+
+noncomputable def hitImpl (environment : Environment auxSpec Coordinate Value Memory) (slot : Nat) :
+    QueryImpl (World auxSpec Coordinate Value) (StateT (State Coordinate Value Memory) SPMF)
+  | .inl input => lazyImpl environment (.inl input)
+  | .inr (.inl (coordinate, candidate)) => StateT.mk fun state =>
+      (fun hit => (hit, afterTrial environment state coordinate candidate hit)) <$> hitTrial slot state coordinate candidate
+  | .inr (.inr coordinate) => lazyImpl environment (.inr (.inr coordinate))
+
+noncomputable def forceFactor (slot : Nat) (state : State Coordinate Value Memory) :
+    (World auxSpec Coordinate Value).Domain → ENNReal
+  | .inr (.inl (coordinate, candidate)) => trialFactor slot state coordinate candidate
+  | _ => 1
+
+theorem hitImpl_apply (environment : Environment auxSpec Coordinate Value Memory) (slot : Nat)
+    (state : State Coordinate Value Memory) (input : (World auxSpec Coordinate Value).Domain)
+    (result : (World auxSpec Coordinate Value).Range input × State Coordinate Value Memory) :
+    (hitImpl environment slot input).run state result =
+      forceFactor slot state input * (forcedImpl environment slot input).run state result := by
+  cases input with
+  | inl input => simp only [hitImpl, forcedImpl, forceFactor, one_mul]
+  | inr input =>
+      cases input with
+      | inl probe =>
+          rcases probe with ⟨coordinate, candidate⟩
+          simp only [hitImpl, forcedImpl, forceFactor, StateT.run_mk, map_eq_bind_pure_comp,
+            Function.comp_def]
+          exact hitTrial_bind_apply slot state coordinate candidate
+            (fun hit : Bool => pure (hit, afterTrial environment state coordinate candidate hit)) result
+      | inr coordinate => simp only [hitImpl, forcedImpl, forceFactor, one_mul]
+
+theorem hitImplRun_weighted_forced {Result : Type} (environment : Environment auxSpec Coordinate Value Memory) (slot : Nat)
+    (computation : OracleComp (World auxSpec Coordinate Value) Result) (state : State Coordinate Value Memory)
+    (payoff : Result × State Coordinate Value Memory → ENNReal) :
+    (∑' result, Pr[= result | runWith (hitImpl environment slot) computation state] * payoff result) =
+      ∑' result, Pr[= result | WeightedQuery.run (forcedImpl environment slot) (forceFactor slot) computation (state, 1)] *
+        (result.2.2 * payoff (result.1, result.2.1)) := by
+  have h := WeightedQuery.run_payoff (hitImpl environment slot) (forcedImpl environment slot) (forceFactor slot)
+    (hitImpl_apply environment slot) computation state 1 payoff
+  simpa only [one_mul, runWith] using h
+
+noncomputable def hitRun {Result : Type} (environment : Environment auxSpec Coordinate Value Memory) (slot : Nat)
+    (computation : OracleComp (World auxSpec Coordinate Value) Result) (state : State Coordinate Value Memory) :=
+  runWith (hitImpl environment slot) computation state >>= fun result =>
+    if slot < result.2.probes then pure result else (failure : SPMF _)
+
+noncomputable def forceWeight (slot : Nat) (state : State Coordinate Value Memory × ENNReal) : ENNReal :=
+  if slot < state.1.probes then state.2 else 0
+
+theorem hitRun_weighted_forced {Result : Type} (environment : Environment auxSpec Coordinate Value Memory) (slot : Nat)
+    (computation : OracleComp (World auxSpec Coordinate Value) Result) (state : State Coordinate Value Memory)
+    (payoff : Result × State Coordinate Value Memory → ENNReal) :
+    (∑' result, Pr[= result | hitRun environment slot computation state] * payoff result) =
+      ∑' result, Pr[= result | WeightedQuery.run (forcedImpl environment slot) (forceFactor slot) computation (state, 1)] *
+        (forceWeight slot result.2 * payoff (result.1, result.2.1)) := by
+  have h := hitImplRun_weighted_forced environment slot computation state
+    (fun result => if slot < result.2.probes then payoff result else 0)
+  rw [hitRun, tsum_probOutput_bind_mul]
+  convert h using 1
+  · apply tsum_congr
+    intro result
+    congr 1
+    by_cases hp : slot < result.2.probes
+    · simp only [if_pos hp, tsum_probOutput_pure_mul]
+    · simp only [if_neg hp, SPMF.probOutput_eq_apply, SPMF.failure_apply, zero_mul, tsum_zero]
+  · apply tsum_congr
+    intro result
+    congr 1
+    simp only [forceWeight, mul_ite, ite_mul, mul_zero, zero_mul]
+
+end SphincsSecurity.Concrete.SecretGuessObservation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessForced.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessForced.lean
new file mode 100644
index 000000000..a99f44566
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessForced.lean
@@ -0,0 +1,79 @@
+import SphincsSecurity.Proof.Forced.SecretGuessObservation
+namespace SphincsSecurity.Concrete.SecretGuessObservation
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+variable {Coordinate Value Memory AuxIndex : Type} {auxSpec : OracleSpec AuxIndex}
+  [Fintype Coordinate] [DecidableEq Coordinate] [DecidableEq Value]
+
+def EligibleAt (slot : Nat) (state : State Coordinate Value Memory) (coordinate : Coordinate) (candidate : Value) : Prop :=
+  state.probes = slot ∧ coordinate ∉ state.retired ∧ trial state.allowed coordinate candidate true ≠ 0
+
+noncomputable def forcedTrial (slot : Nat) (state : State Coordinate Value Memory)
+    (coordinate : Coordinate) (candidate : Value) : SPMF Bool :=
+  if EligibleAt slot state coordinate candidate then pure true else trial state.allowed coordinate candidate
+
+theorem forcedTrial_nonzero (slot : Nat) (state : State Coordinate Value Memory)
+    (coordinate : Coordinate) (candidate : Value) (hit : Bool)
+    (hhit : forcedTrial slot state coordinate candidate hit ≠ 0) : trial state.allowed coordinate candidate hit ≠ 0 := by
+  by_cases he : EligibleAt slot state coordinate candidate
+  · simp only [forcedTrial, if_pos he, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hhit
+    subst hit
+    exact he.2.2
+  · simpa only [forcedTrial, if_neg he] using hhit
+
+noncomputable def forcedImpl (environment : Environment auxSpec Coordinate Value Memory) (slot : Nat) :
+    QueryImpl (World auxSpec Coordinate Value) (StateT (State Coordinate Value Memory) SPMF)
+  | .inl input => lazyImpl environment (.inl input)
+  | .inr (.inl (coordinate, candidate)) => StateT.mk fun state =>
+      (fun hit => (hit, afterTrial environment state coordinate candidate hit)) <$> forcedTrial slot state coordinate candidate
+  | .inr (.inr coordinate) => lazyImpl environment (.inr (.inr coordinate))
+
+noncomputable def forcedRun {Result : Type} (environment : Environment auxSpec Coordinate Value Memory) (slot : Nat)
+    (computation : OracleComp (World auxSpec Coordinate Value) Result) (state : State Coordinate Value Memory) :=
+  runWith (forcedImpl environment slot) computation state
+
+theorem forcedImpl_nonzero (environment : Environment auxSpec Coordinate Value Memory) (slot : Nat)
+    (state : State Coordinate Value Memory) (input : (World auxSpec Coordinate Value).Domain)
+    (result : (World auxSpec Coordinate Value).Range input × State Coordinate Value Memory)
+    (hr : (forcedImpl environment slot input).run state result ≠ 0) :
+    (lazyImpl environment input).run state result ≠ 0 := by
+  cases input with
+  | inl input => exact hr
+  | inr input =>
+      cases input with
+      | inl probe =>
+          rcases probe with ⟨coordinate, candidate⟩
+          simp only [forcedImpl, lazyImpl, StateT.run_mk, map_eq_bind_pure_comp,
+            RetainedObservation.bind_nonzero] at hr ⊢
+          obtain ⟨hit, hh, hr⟩ := hr
+          exact ⟨hit, forcedTrial_nonzero slot state coordinate candidate hit hh, hr⟩
+      | inr coordinate => exact hr
+
+theorem forcedRun_nonzero {Result : Type} (environment : Environment auxSpec Coordinate Value Memory) (slot : Nat)
+    (computation : OracleComp (World auxSpec Coordinate Value) Result) (state : State Coordinate Value Memory)
+    (result : Result × State Coordinate Value Memory) (hr : forcedRun environment slot computation state result ≠ 0) :
+    lazyRun environment computation state result ≠ 0 := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value => exact hr
+  | query_bind input next ih =>
+      simp only [forcedRun, lazyRun, runWith_query_bind, RetainedObservation.bind_nonzero] at hr ⊢
+      obtain ⟨middle, hm, hr⟩ := hr
+      exact ⟨middle, forcedImpl_nonzero environment slot state input middle hm, ih middle.1 middle.2 result hr⟩
+
+theorem forcedImpl_probes (environment : Environment auxSpec Coordinate Value Memory) (slot : Nat)
+    (state : State Coordinate Value Memory) (input : (World auxSpec Coordinate Value).Domain)
+    (result : (World auxSpec Coordinate Value).Range input × State Coordinate Value Memory)
+    (hr : (forcedImpl environment slot input).run state result ≠ 0) :
+    result.2.probes = state.probes + probeStep input :=
+  lazyImpl_probes environment state input result (forcedImpl_nonzero environment slot state input result hr)
+
+theorem forcedRun_nonempty {Result : Type} (environment : Environment auxSpec Coordinate Value Memory) (slot : Nat)
+    (computation : OracleComp (World auxSpec Coordinate Value) Result) (state : State Coordinate Value Memory)
+    (ha : ∀ coordinate, (state.allowed coordinate).Nonempty) (result : Result × State Coordinate Value Memory)
+    (hr : forcedRun environment slot computation state result ≠ 0) : ∀ coordinate, (result.2.allowed coordinate).Nonempty :=
+  lazyRun_nonempty environment computation state ha result (forcedRun_nonzero environment slot computation state result hr)
+
+end SphincsSecurity.Concrete.SecretGuessObservation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessForcedProgram.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessForcedProgram.lean
new file mode 100644
index 000000000..db9aeeb41
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessForcedProgram.lean
@@ -0,0 +1,105 @@
+import SphincsSecurity.Proof.Forced.SecretGuessForced
+import SphincsSecurity.Proof.Forced.SecretGuessErasure
+namespace SphincsSecurity.Concrete.SecretGuessObservation
+
+open _root_.OracleComp OracleSpec UniformTableCompletion
+set_option backward.isDefEq.respectTransparency false
+
+variable {Coordinate Value AuxIndex TargetIndex : Type} {auxSpec : OracleSpec AuxIndex}
+  {targetSpec : OracleSpec TargetIndex}
+  [Fintype Coordinate] [DecidableEq Coordinate] [DecidableEq Value]
+
+noncomputable def plainAfterTrial (state : State Coordinate Value PUnit)
+    (coordinate : Coordinate) (candidate : Value) (hit : Bool) : State Coordinate Value PUnit :=
+  { allowed := restrict state.allowed coordinate candidate hit
+    retired := if hit then insert coordinate state.retired else state.retired
+    guesses := if hit = true ∧ coordinate ∉ state.retired then insert coordinate state.guesses else state.guesses
+    probes := state.probes + 1
+    memory := PUnit.unit }
+
+def plainAfterDisclosure (state : State Coordinate Value PUnit)
+    (coordinate : Coordinate) (value : Value) : State Coordinate Value PUnit :=
+  { state with
+    allowed := discloseTableValue state.allowed coordinate value
+    retired := insert coordinate state.retired
+    memory := PUnit.unit }
+
+noncomputable def forcedProgram {Result : Type}
+    (auxiliary : QueryImpl auxSpec (OracleComp targetSpec))
+    (sampleBool : SPMF Bool → OracleComp targetSpec Bool)
+    (sampleValue : SPMF Value → OracleComp targetSpec Value) (slot : Nat)
+    (computation : OracleComp (World auxSpec Coordinate Value) Result) :
+    State Coordinate Value PUnit → OracleComp targetSpec (Result × State Coordinate Value PUnit) :=
+  OracleComp.construct (fun value state => pure (value, state)) (fun input _ next state =>
+    match input with
+    | .inl input => auxiliary input >>= fun answer => next answer state
+    | .inr (.inl (coordinate, candidate)) =>
+        sampleBool (forcedTrial slot state coordinate candidate) >>= fun hit =>
+          next hit (plainAfterTrial state coordinate candidate hit)
+    | .inr (.inr coordinate) => sampleValue (cell (state.allowed coordinate)) >>= fun value =>
+        next value (plainAfterDisclosure state coordinate value)) computation
+
+theorem forcedProgram_pure {Result : Type} (auxiliary : QueryImpl auxSpec (OracleComp targetSpec))
+    (sampleBool : SPMF Bool → OracleComp targetSpec Bool)
+    (sampleValue : SPMF Value → OracleComp targetSpec Value) (slot : Nat)
+    (value : Result) (state : State Coordinate Value PUnit) :
+    forcedProgram auxiliary sampleBool sampleValue slot (pure value) state = pure (value, state) := rfl
+
+theorem forcedProgram_query_bind {Result : Type} (auxiliary : QueryImpl auxSpec (OracleComp targetSpec))
+    (sampleBool : SPMF Bool → OracleComp targetSpec Bool)
+    (sampleValue : SPMF Value → OracleComp targetSpec Value) (slot : Nat)
+    (input : (World auxSpec Coordinate Value).Domain)
+    (next : (World auxSpec Coordinate Value).Range input → OracleComp (World auxSpec Coordinate Value) Result)
+    (state : State Coordinate Value PUnit) :
+    forcedProgram auxiliary sampleBool sampleValue slot
+      (liftM ((World auxSpec Coordinate Value).query input) >>= next) state =
+      match input with
+      | .inl input => auxiliary input >>= fun answer => forcedProgram auxiliary sampleBool sampleValue slot (next answer) state
+      | .inr (.inl (coordinate, candidate)) =>
+          sampleBool (forcedTrial slot state coordinate candidate) >>= fun hit =>
+            forcedProgram auxiliary sampleBool sampleValue slot (next hit) (plainAfterTrial state coordinate candidate hit)
+      | .inr (.inr coordinate) => sampleValue (cell (state.allowed coordinate)) >>= fun value =>
+          forcedProgram auxiliary sampleBool sampleValue slot (next value) (plainAfterDisclosure state coordinate value) := by
+  rw [forcedProgram, OracleComp.construct_query_bind]
+  cases input with
+  | inl input => rfl
+  | inr input => cases input <;> rfl
+
+theorem simulateQ_forcedProgram {Result : Type} (auxiliary : QueryImpl auxSpec ProbComp)
+    (program : QueryImpl auxSpec (OracleComp targetSpec))
+    (sampleBool : SPMF Bool → OracleComp targetSpec Bool)
+    (sampleValue : SPMF Value → OracleComp targetSpec Value)
+    (runtime : QueryImpl targetSpec SPMF)
+    (hauxiliary : ∀ input, simulateQ runtime (program input) = 𝒟[auxiliary input])
+    (hbool : ∀ law, simulateQ runtime (sampleBool law) = law)
+    (hvalue : ∀ law, simulateQ runtime (sampleValue law) = law)
+    (slot : Nat) (computation : OracleComp (World auxSpec Coordinate Value) Result)
+    (state : State Coordinate Value PUnit) :
+    simulateQ runtime (forcedProgram program sampleBool sampleValue slot computation state) =
+      forcedRun (environment auxiliary) slot computation state := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [forcedProgram_pure, simulateQ_pure, forcedRun, runWith_pure]
+  | query_bind input next ih =>
+      rw [forcedProgram_query_bind, forcedRun, runWith_query_bind]
+      cases input with
+      | inl input =>
+          simp only [simulateQ_bind, hauxiliary, forcedImpl, lazyImpl, StateT.run_mk,
+            environment, evalDist_map, Functor.map_map, bind_map_left]
+          apply congrArg (𝒟[auxiliary input] >>= ·)
+          funext answer
+          exact ih answer state
+      | inr input =>
+          cases input with
+          | inl probe =>
+              rcases probe with ⟨coordinate, candidate⟩
+              simp only [simulateQ_bind, hbool, forcedImpl, StateT.run_mk, bind_map_left]
+              apply congrArg (forcedTrial slot state coordinate candidate >>= ·)
+              funext hit
+              exact ih hit (plainAfterTrial state coordinate candidate hit)
+          | inr coordinate =>
+              simp only [simulateQ_bind, hvalue, forcedImpl, lazyImpl, StateT.run_mk, bind_map_left]
+              apply congrArg (cell (state.allowed coordinate) >>= ·)
+              funext value
+              exact ih value (plainAfterDisclosure state coordinate value)
+
+end SphincsSecurity.Concrete.SecretGuessObservation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessHitPayoff.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessHitPayoff.lean
new file mode 100644
index 000000000..c3e825b8d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessHitPayoff.lean
@@ -0,0 +1,67 @@
+import SphincsSecurity.Proof.Forced.SecretGuessHitSum
+namespace SphincsSecurity.Concrete.SecretGuessObservation
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+variable {Coordinate Value Memory AuxIndex : Type} {auxSpec : OracleSpec AuxIndex}
+  [Fintype Coordinate] [DecidableEq Coordinate] [DecidableEq Value] [Fintype Value] [Nonempty Value]
+
+omit [Nonempty Value] in
+theorem lazyRun_guess_payoff_le_sum {Result : Type} (environment : Environment auxSpec Coordinate Value Memory)
+    (computation : OracleComp (World auxSpec Coordinate Value) Result) (memory : Memory) (budget : Nat)
+    (hbudget : ∀ result, lazyRun environment computation (initialState memory) result ≠ 0 → result.2.probes ≤ budget)
+    (payoff : Result × State Coordinate Value Memory → ENNReal) :
+    (∑' result, Pr[= result | lazyRun environment computation (initialState memory)] *
+      (if result.2.guesses.Nonempty then payoff result else 0)) ≤
+      ∑ slot ∈ Finset.range budget, ∑' result,
+        Pr[= result | hitRun environment slot computation (initialState memory)] * payoff result := by
+  rw [← Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)]
+  apply ENNReal.tsum_le_tsum
+  intro result
+  by_cases hz : lazyRun environment computation (initialState memory) result = 0
+  · simp only [SPMF.probOutput_eq_apply, hz, zero_mul]
+    exact bot_le
+  by_cases hg : result.2.guesses.Nonempty
+  · rw [if_pos hg]
+    have h := lazyRun_new_guesses_le_sum environment computation (initialState memory) result budget (hbudget result hz)
+      (show result.2.guesses ≠ (initialState memory : State Coordinate Value Memory).guesses from hg.ne_empty)
+    have hp := mul_le_mul' h (le_rfl : payoff result ≤ payoff result)
+    simpa only [initialState, ← Finset.range_eq_Ico, Finset.sum_mul, SPMF.probOutput_eq_apply] using hp
+  · simp only [if_neg hg, mul_zero]
+    exact bot_le
+
+theorem lazyRun_guess_payoff_le_forced {Result : Type} (environment : Environment auxSpec Coordinate Value Memory)
+    (computation : OracleComp (World auxSpec Coordinate Value) Result) (memory : Memory) (budget : Nat)
+    (hbudget : ∀ result, lazyRun environment computation (initialState memory) result ≠ 0 → result.2.probes ≤ budget)
+    (payoff : Result × State Coordinate Value Memory → ENNReal) :
+    (∑' result, Pr[= result | lazyRun environment computation (initialState memory)] *
+      (if result.2.guesses.Nonempty then payoff result else 0)) ≤
+      ((Fintype.card Value - budget : Nat) : ENNReal)⁻¹ *
+        ∑ slot ∈ Finset.range budget, ∑' result,
+          Pr[= result | forcedRun environment slot computation (initialState memory)] * payoff result := by
+  apply (lazyRun_guess_payoff_le_sum environment computation memory budget hbudget payoff).trans
+  rw [Finset.mul_sum]
+  apply Finset.sum_le_sum
+  intro slot hslot
+  exact hitRun_payoff_le_forced environment budget slot (Finset.mem_range.mp hslot).le computation memory payoff
+
+theorem lazyRun_event_le_forced {Result : Type} (environment : Environment auxSpec Coordinate Value Memory)
+    (computation : OracleComp (World auxSpec Coordinate Value) Result) (memory : Memory) (budget : Nat)
+    (hbudget : ∀ result, lazyRun environment computation (initialState memory) result ≠ 0 → result.2.probes ≤ budget)
+    (event : Result × State Coordinate Value Memory → Prop) (payoff : Result × State Coordinate Value Memory → ENNReal)
+    (hevent : ∀ result, lazyRun environment computation (initialState memory) result ≠ 0 → event result →
+      result.2.guesses.Nonempty ∧ 1 ≤ payoff result) :
+    Pr[event | lazyRun environment computation (initialState memory)] ≤
+      ((Fintype.card Value - budget : Nat) : ENNReal)⁻¹ *
+        ∑ slot ∈ Finset.range budget, ∑' result,
+          Pr[= result | forcedRun environment slot computation (initialState memory)] * payoff result := by
+  apply (probEvent_le_tsum_probOutput_mul_cost_of_mem_support _ _
+    (fun result => if result.2.guesses.Nonempty then payoff result else 0) ?_).trans
+      (lazyRun_guess_payoff_le_forced environment computation memory budget hbudget payoff)
+  intro result hr he
+  have h := hevent result (by simpa only [mem_support_iff, SPMF.probOutput_eq_apply] using hr) he
+  simpa only [if_pos h.1] using h.2
+
+end SphincsSecurity.Concrete.SecretGuessObservation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessHitRun.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessHitRun.lean
new file mode 100644
index 000000000..da4a8600a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessHitRun.lean
@@ -0,0 +1,104 @@
+import SphincsSecurity.Proof.Forced.SecretGuessForceBound
+namespace SphincsSecurity.Concrete.SecretGuessObservation
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+variable {Coordinate Value Memory AuxIndex : Type} {auxSpec : OracleSpec AuxIndex}
+  [Fintype Coordinate] [DecidableEq Coordinate] [DecidableEq Value]
+
+theorem lazyRun_probes_mono {Result : Type} (environment : Environment auxSpec Coordinate Value Memory)
+    (computation : OracleComp (World auxSpec Coordinate Value) Result) (state : State Coordinate Value Memory)
+    (result : Result × State Coordinate Value Memory) (hr : lazyRun environment computation state result ≠ 0) :
+    state.probes ≤ result.2.probes := by
+  apply lazyRun_preserves environment (fun next => state.probes ≤ next.probes) _ computation state le_rfl result hr
+  intro middle hm input next hn
+  rw [lazyImpl_probes environment middle input next hn]
+  exact hm.trans (Nat.le_add_right _ _)
+
+theorem hitImpl_eq_lazy (environment : Environment auxSpec Coordinate Value Memory) (slot : Nat)
+    (state : State Coordinate Value Memory) (hne : state.probes ≠ slot) (input : (World auxSpec Coordinate Value).Domain) :
+    (hitImpl environment slot input).run state = (lazyImpl environment input).run state := by
+  cases input with
+  | inl input => rfl
+  | inr input =>
+      cases input with
+      | inl probe =>
+          rcases probe with ⟨coordinate, candidate⟩
+          simp only [hitImpl, lazyImpl, StateT.run_mk, hitTrial, if_neg hne]
+      | inr coordinate => rfl
+
+theorem hitImplRun_after {Result : Type} (environment : Environment auxSpec Coordinate Value Memory) (slot : Nat)
+    (computation : OracleComp (World auxSpec Coordinate Value) Result) (state : State Coordinate Value Memory)
+    (hslot : slot < state.probes) : runWith (hitImpl environment slot) computation state = lazyRun environment computation state := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [lazyRun, runWith_pure]
+  | query_bind input next ih =>
+      rw [runWith_query_bind, lazyRun, runWith_query_bind, hitImpl_eq_lazy environment slot state (Nat.ne_of_gt hslot)]
+      apply RetainedObservation.bind_congr
+      intro middle hm
+      have hp := lazyImpl_probes environment state input middle hm
+      apply ih middle.1 middle.2
+      rw [hp]
+      exact hslot.trans_le (Nat.le_add_right _ _)
+
+theorem hitRun_apply {Result : Type} (environment : Environment auxSpec Coordinate Value Memory) (slot : Nat)
+    (computation : OracleComp (World auxSpec Coordinate Value) Result) (state : State Coordinate Value Memory)
+    (result : Result × State Coordinate Value Memory) : hitRun environment slot computation state result =
+      if slot < result.2.probes then runWith (hitImpl environment slot) computation state result else 0 := by
+  rw [hitRun, SPMF.bind_apply_eq_tsum, tsum_eq_single result]
+  · split <;> simp only [SPMF.pure_apply_self, SPMF.failure_apply, mul_one, mul_zero]
+  · intro other hother
+    split <;> simp only [SPMF.pure_apply, if_neg (Ne.symm hother), SPMF.failure_apply, mul_zero]
+
+theorem hitRun_after {Result : Type} (environment : Environment auxSpec Coordinate Value Memory) (slot : Nat)
+    (computation : OracleComp (World auxSpec Coordinate Value) Result) (state : State Coordinate Value Memory)
+    (hslot : slot < state.probes) : hitRun environment slot computation state = lazyRun environment computation state := by
+  apply SPMF.ext
+  intro result
+  rw [hitRun_apply, hitImplRun_after environment slot computation state hslot]
+  by_cases hp : slot < result.2.probes
+  · exact if_pos hp
+  · rw [if_neg hp]
+    symm
+    by_contra hr
+    exact hp (hslot.trans_le (lazyRun_probes_mono environment computation state result hr))
+
+theorem hitRun_query_bind {Result : Type} (environment : Environment auxSpec Coordinate Value Memory) (slot : Nat)
+    (input : (World auxSpec Coordinate Value).Domain)
+    (next : (World auxSpec Coordinate Value).Range input → OracleComp (World auxSpec Coordinate Value) Result)
+    (state : State Coordinate Value Memory) :
+    hitRun environment slot (liftM ((World auxSpec Coordinate Value).query input) >>= next) state =
+      ((hitImpl environment slot input).run state >>= fun middle => hitRun environment slot (next middle.1) middle.2) := by
+  simp only [hitRun, runWith_query_bind, bind_assoc]
+
+theorem hitRun_probe_at {Result : Type} (environment : Environment auxSpec Coordinate Value Memory)
+    (coordinate : Coordinate) (candidate : Value)
+    (next : Bool → OracleComp (World auxSpec Coordinate Value) Result) (state : State Coordinate Value Memory) :
+    hitRun environment state.probes
+      (liftM ((World auxSpec Coordinate Value).query (.inr (.inl (coordinate, candidate)))) >>= next) state =
+      (trial state.allowed coordinate candidate >>= fun hit =>
+        if hit = true ∧ coordinate ∉ state.retired then lazyRun environment (next hit) (afterTrial environment state coordinate candidate hit)
+        else failure) := by
+  rw [hitRun_query_bind]
+  simp only [hitImpl, StateT.run_mk, bind_map_left, hitTrial, ite_true, bind_assoc]
+  apply congrArg (trial state.allowed coordinate candidate >>= ·)
+  funext hit
+  by_cases hh : hit = true ∧ coordinate ∉ state.retired
+  · rw [if_pos hh, pure_bind, hitRun_after environment state.probes _ _ (Nat.lt_succ_self _)]
+    rw [if_pos hh]
+  · simp only [if_neg hh, failure_bind]
+
+theorem hitRun_probe_other {Result : Type} (environment : Environment auxSpec Coordinate Value Memory) (slot : Nat)
+    (coordinate : Coordinate) (candidate : Value)
+    (next : Bool → OracleComp (World auxSpec Coordinate Value) Result) (state : State Coordinate Value Memory)
+    (hne : state.probes ≠ slot) :
+    hitRun environment slot
+      (liftM ((World auxSpec Coordinate Value).query (.inr (.inl (coordinate, candidate)))) >>= next) state =
+      (trial state.allowed coordinate candidate >>= fun hit => hitRun environment slot (next hit) (afterTrial environment state coordinate candidate hit)) := by
+  rw [hitRun_query_bind, hitImpl_eq_lazy environment slot state hne]
+  simp only [lazyImpl, StateT.run_mk, bind_map_left]
+  rfl
+
+end SphincsSecurity.Concrete.SecretGuessObservation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessHitSum.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessHitSum.lean
new file mode 100644
index 000000000..3264c2a2d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessHitSum.lean
@@ -0,0 +1,148 @@
+import SphincsSecurity.Proof.Forced.SecretGuessHitRun
+namespace SphincsSecurity.Concrete.SecretGuessObservation
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+private theorem sum_bind_apply {Index First Result : Type} (indices : Finset Index) (law : SPMF First)
+    (next : Index → First → SPMF Result) (result : Result) :
+    (∑ index ∈ indices, (law >>= next index) result) =
+      ∑' first, law first * ∑ index ∈ indices, next index first result := by
+  simp only [SPMF.bind_apply_eq_tsum]
+  rw [← Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)]
+  simp only [Finset.mul_sum]
+
+variable {Coordinate Value Memory AuxIndex : Type} {auxSpec : OracleSpec AuxIndex}
+  [Fintype Coordinate] [DecidableEq Coordinate] [DecidableEq Value]
+
+theorem hitImpl_no_probe (environment : Environment auxSpec Coordinate Value Memory) (slot : Nat)
+    (input : (World auxSpec Coordinate Value).Domain) (hn : probeStep input = 0) :
+    hitImpl environment slot input = lazyImpl environment input := by
+  cases input with
+  | inl input => rfl
+  | inr input =>
+      cases input with
+      | inl probe => cases hn
+      | inr coordinate => rfl
+
+theorem lazyImpl_no_probe_guesses (environment : Environment auxSpec Coordinate Value Memory)
+    (input : (World auxSpec Coordinate Value).Domain) (hn : probeStep input = 0)
+    (state : State Coordinate Value Memory) (result : (World auxSpec Coordinate Value).Range input × State Coordinate Value Memory)
+    (hr : (lazyImpl environment input).run state result ≠ 0) : result.2.guesses = state.guesses := by
+  cases input with
+  | inl input =>
+      simp only [lazyImpl, StateT.run_mk, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero,
+        Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+      obtain ⟨answer, _, rfl⟩ := hr
+      rfl
+  | inr input =>
+      cases input with
+      | inl probe => cases hn
+      | inr coordinate =>
+          simp only [lazyImpl, StateT.run_mk, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero,
+            Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+          obtain ⟨value, _, rfl⟩ := hr
+          rfl
+
+theorem hitRun_sum_no_probe {Result : Type} (environment : Environment auxSpec Coordinate Value Memory)
+    (slots : Finset Nat) (input : (World auxSpec Coordinate Value).Domain) (hn : probeStep input = 0)
+    (next : (World auxSpec Coordinate Value).Range input → OracleComp (World auxSpec Coordinate Value) Result)
+    (state : State Coordinate Value Memory) (result : Result × State Coordinate Value Memory) :
+    (∑ slot ∈ slots, hitRun environment slot (liftM ((World auxSpec Coordinate Value).query input) >>= next) state result) =
+      ∑' middle, (lazyImpl environment input).run state middle *
+        ∑ slot ∈ slots, hitRun environment slot (next middle.1) middle.2 result := by
+  simp_rw [hitRun_query_bind, hitImpl_no_probe environment _ input hn]
+  exact sum_bind_apply slots _ _ result
+
+theorem hitRun_sum_probe {Result : Type} (environment : Environment auxSpec Coordinate Value Memory) (budget : Nat)
+    (coordinate : Coordinate) (candidate : Value) (next : Bool → OracleComp (World auxSpec Coordinate Value) Result)
+    (state : State Coordinate Value Memory) (result : Result × State Coordinate Value Memory) (hbudget : state.probes < budget) :
+    (∑ slot ∈ Finset.Ico state.probes budget, hitRun environment slot
+      (liftM ((World auxSpec Coordinate Value).query (.inr (.inl (coordinate, candidate)))) >>= next) state result) =
+      ∑' hit, trial state.allowed coordinate candidate hit *
+        ((if hit = true ∧ coordinate ∉ state.retired then lazyRun environment (next hit) (afterTrial environment state coordinate candidate hit) result else 0) +
+          ∑ slot ∈ Finset.Ico (state.probes + 1) budget,
+            hitRun environment slot (next hit) (afterTrial environment state coordinate candidate hit) result) := by
+  rw [Finset.sum_eq_sum_Ico_succ_bot hbudget, hitRun_probe_at, SPMF.bind_apply_eq_tsum]
+  have htail :
+      (∑ slot ∈ Finset.Ico (state.probes + 1) budget, hitRun environment slot
+        (liftM ((World auxSpec Coordinate Value).query (.inr (.inl (coordinate, candidate)))) >>= next) state result) =
+      ∑' hit, trial state.allowed coordinate candidate hit *
+        ∑ slot ∈ Finset.Ico (state.probes + 1) budget,
+          hitRun environment slot (next hit) (afterTrial environment state coordinate candidate hit) result := by
+    calc
+      _ = ∑ slot ∈ Finset.Ico (state.probes + 1) budget,
+          (trial state.allowed coordinate candidate >>= fun hit =>
+            hitRun environment slot (next hit) (afterTrial environment state coordinate candidate hit)) result := by
+        apply Finset.sum_congr rfl
+        intro slot hslot
+        rw [hitRun_probe_other environment slot coordinate candidate next state (by
+          have h := (Finset.mem_Ico.mp hslot).1
+          omega)]
+      _ = _ := sum_bind_apply _ _ _ result
+  rw [htail, ← ENNReal.tsum_add]
+  apply tsum_congr
+  intro hit
+  by_cases hh : hit = true ∧ coordinate ∉ state.retired
+  · simp only [if_pos hh, mul_add]
+  · simp only [if_neg hh, SPMF.failure_apply, mul_zero, zero_add]
+
+theorem lazyRun_new_guesses_le_sum {Result : Type} (environment : Environment auxSpec Coordinate Value Memory)
+    (computation : OracleComp (World auxSpec Coordinate Value) Result) (state : State Coordinate Value Memory)
+    (result : Result × State Coordinate Value Memory) (budget : Nat) (hbudget : result.2.probes ≤ budget)
+    (hnew : result.2.guesses ≠ state.guesses) :
+    lazyRun environment computation state result ≤
+      ∑ slot ∈ Finset.Ico state.probes budget, hitRun environment slot computation state result := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value =>
+      by_cases he : result = (value, state)
+      · subst result
+        exact False.elim (hnew rfl)
+      · simp only [lazyRun, runWith_pure, SPMF.pure_apply, if_neg he]
+        exact bot_le
+  | query_bind input next ih =>
+      by_cases hn : probeStep input = 0
+      · rw [hitRun_sum_no_probe environment _ input hn, lazyRun, runWith_query_bind, SPMF.bind_apply_eq_tsum]
+        apply ENNReal.tsum_le_tsum
+        intro middle
+        by_cases hm : (lazyImpl environment input).run state middle = 0
+        · simp only [hm, zero_mul, le_refl]
+        · have hp := lazyImpl_probes environment state input middle hm
+          rw [hn, Nat.add_zero] at hp
+          have hg := lazyImpl_no_probe_guesses environment input hn state middle hm
+          have h := ih middle.1 middle.2 (hg ▸ hnew)
+          rw [hp] at h
+          exact mul_le_mul' le_rfl h
+      · cases input with
+        | inl input => exact False.elim (hn rfl)
+        | inr input =>
+            cases input with
+            | inr coordinate => exact False.elim (hn rfl)
+            | inl probe =>
+                rcases probe with ⟨coordinate, candidate⟩
+                by_cases hz : lazyRun environment
+                    (liftM ((World auxSpec Coordinate Value).query (.inr (.inl (coordinate, candidate)))) >>= next) state result = 0
+                · rw [hz]
+                  exact bot_le
+                have hpositive := hz
+                rw [lazyRun, runWith_query_bind] at hpositive
+                simp only [lazyImpl, StateT.run_mk, bind_map_left, RetainedObservation.bind_nonzero] at hpositive
+                obtain ⟨hit, _, htail⟩ := hpositive
+                have hp := lazyRun_probes_mono environment (next hit) (afterTrial environment state coordinate candidate hit) result htail
+                have hroom : state.probes < budget := by
+                  change state.probes + 1 ≤ result.2.probes at hp
+                  omega
+                rw [hitRun_sum_probe environment budget coordinate candidate next state result hroom]
+                simp only [lazyRun, runWith_query_bind, lazyImpl, StateT.run_mk, bind_map_left, SPMF.bind_apply_eq_tsum]
+                apply ENNReal.tsum_le_tsum
+                intro hit
+                apply mul_le_mul' le_rfl
+                by_cases hh : hit = true ∧ coordinate ∉ state.retired
+                · rw [if_pos hh]
+                  exact le_add_right le_rfl
+                · rw [if_neg hh, zero_add]
+                  apply ih hit (afterTrial environment state coordinate candidate hit)
+                  simpa only [afterTrial, if_neg hh] using hnew
+
+end SphincsSecurity.Concrete.SecretGuessObservation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessObservation.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessObservation.lean
new file mode 100644
index 000000000..6f933e951
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessObservation.lean
@@ -0,0 +1,479 @@
+import SphincsSecurity.Proof.Residual.RetainedObservation
+namespace SphincsSecurity.Concrete.SecretGuessObservation
+
+open _root_.OracleComp OracleSpec ENNReal UniformTableCompletion
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+variable {Coordinate Value : Type} [Fintype Coordinate] [DecidableEq Coordinate] [DecidableEq Value]
+
+def restrict (allowed : Coordinate → Finset Value) (coordinate : Coordinate) (candidate : Value)
+    (hit : Bool) : Coordinate → Finset Value :=
+  Function.update allowed coordinate ((allowed coordinate).filter fun value => hit = decide (value = candidate))
+
+omit [Fintype Coordinate] in
+theorem restrict_subset (allowed : Coordinate → Finset Value) (coordinate : Coordinate) (candidate : Value)
+    (hit : Bool) (other : Coordinate) : restrict allowed coordinate candidate hit other ⊆ allowed other := by
+  by_cases heq : other = coordinate
+  · subst other
+    rw [restrict, Function.update_self]
+    exact Finset.filter_subset _ _
+  · simp only [restrict, Function.update_of_ne heq, Finset.Subset.refl]
+
+omit [Fintype Coordinate] in
+theorem restrict_membership (allowed : Coordinate → Finset Value) (coordinate : Coordinate) (candidate : Value)
+    (hit : Bool) (labels : Coordinate → Value) :
+    (∀ other, labels other ∈ restrict allowed coordinate candidate hit other) ↔
+      (∀ other, labels other ∈ allowed other) ∧ hit = decide (labels coordinate = candidate) := by
+  constructor
+  · intro h
+    refine ⟨fun other => restrict_subset allowed coordinate candidate hit other (h other), ?_⟩
+    have hc := h coordinate
+    rw [restrict, Function.update_self, Finset.mem_filter] at hc
+    exact hc.2
+  · rintro ⟨h, hh⟩ other
+    by_cases heq : other = coordinate
+    · subst other
+      rw [restrict, Function.update_self]
+      exact Finset.mem_filter.mpr ⟨h coordinate, hh⟩
+    · simpa only [restrict, Function.update_of_ne heq] using h other
+
+theorem restrict_mass (allowed : Coordinate → Finset Value) (coordinate : Coordinate) (candidate : Value)
+    (hit : Bool) (labels : Coordinate → Value) :
+    (if hit = decide (labels coordinate = candidate) then complete allowed labels else 0) =
+      restrictionWeight allowed (restrict allowed coordinate candidate hit) *
+        complete (restrict allowed coordinate candidate hit) labels := by
+  have h := restrict_guard allowed _ (restrict_subset allowed coordinate candidate hit) _
+    (restrict_membership allowed coordinate candidate hit) labels
+  by_cases hh : hit = decide (labels coordinate = candidate)
+  · simpa only [if_pos hh] using h
+  · simpa only [if_neg hh] using h
+
+noncomputable def trial (allowed : Coordinate → Finset Value) (coordinate : Coordinate) (candidate : Value) : SPMF Bool :=
+  complete allowed >>= fun labels => pure (decide (labels coordinate = candidate))
+
+theorem trial_apply (allowed : Coordinate → Finset Value) (coordinate : Coordinate) (candidate : Value) (hit : Bool) :
+    trial allowed coordinate candidate hit = restrictionWeight allowed (restrict allowed coordinate candidate hit) := by
+  rw [trial, SPMF.bind_apply_eq_tsum]
+  simp only [SPMF.pure_apply, mul_ite, mul_one, mul_zero, restrict_mass, ENNReal.tsum_mul_left,
+    weight_tsum_complete]
+
+theorem trial_mass (allowed : Coordinate → Finset Value) (coordinate : Coordinate) (candidate : Value)
+    (hit : Bool) (labels : Coordinate → Value) :
+    trial allowed coordinate candidate hit * complete (restrict allowed coordinate candidate hit) labels =
+      if hit = decide (labels coordinate = candidate) then complete allowed labels else 0 := by
+  rw [trial_apply, restrict_mass]
+
+theorem trial_nonempty (allowed : Coordinate → Finset Value) (coordinate : Coordinate) (candidate : Value)
+    (hit : Bool) (hhit : trial allowed coordinate candidate hit ≠ 0) :
+    ∀ other, (restrict allowed coordinate candidate hit other).Nonempty := by
+  by_contra hn
+  rw [trial_apply, weight_of_empty _ _ hn] at hhit
+  exact hhit rfl
+
+theorem bind_trial {Result : Type} (allowed : Coordinate → Finset Value) (coordinate : Coordinate) (candidate : Value)
+    (next : Bool → (Coordinate → Value) → SPMF Result) :
+    (complete allowed >>= fun labels => next (decide (labels coordinate = candidate)) labels) =
+      (trial allowed coordinate candidate >>= fun hit =>
+        complete (restrict allowed coordinate candidate hit) >>= next hit) := by
+  apply SPMF.ext
+  intro result
+  simp only [SPMF.bind_apply_eq_tsum, ← ENNReal.tsum_mul_left, ← mul_assoc, trial_mass, ite_mul, zero_mul]
+  rw [ENNReal.tsum_comm]
+  simp [Classical.em]
+
+theorem trial_true (allowed : Coordinate → Finset Value) (ha : ∀ coordinate, (allowed coordinate).Nonempty)
+    (coordinate : Coordinate) (candidate : Value) :
+    trial allowed coordinate candidate true =
+      if candidate ∈ allowed coordinate then ((allowed coordinate).card : ENNReal)⁻¹ else 0 := by
+  rw [trial, SPMF.bind_apply_eq_tsum, complete_of_nonempty allowed ha]
+  simpa only [SPMF.pure_apply, SPMF.liftM_apply, eq_comm (a := true), decide_eq_true_eq, mul_ite, mul_one, mul_zero,
+    probEvent_eq_tsum_ite, PMF.probOutput_eq_apply] using probEvent_uniformTable_eq allowed ha coordinate candidate
+
+structure State (Coordinate Value Memory : Type) where
+  allowed : Coordinate → Finset Value
+  retired : Finset Coordinate
+  guesses : Finset Coordinate
+  probes : Nat
+  memory : Memory
+
+def SecretSpec (Coordinate Value : Type) : OracleSpec ((Coordinate × Value) ⊕ Coordinate)
+  | .inl _ => Bool
+  | .inr _ => Value
+
+abbrev World {AuxIndex : Type} (auxSpec : OracleSpec AuxIndex) (Coordinate Value : Type) :=
+  auxSpec + SecretSpec Coordinate Value
+
+structure Environment {AuxIndex : Type} (auxSpec : OracleSpec AuxIndex) (Coordinate Value Memory : Type) where
+  auxiliary : State Coordinate Value Memory → (input : auxSpec.Domain) → PMF (auxSpec.Range input × Memory)
+  trial : Memory → Coordinate → Value → Bool → Memory
+  disclosure : Memory → Coordinate → Value → Memory
+
+variable {Memory AuxIndex : Type} {auxSpec : OracleSpec AuxIndex}
+
+def afterTrial (environment : Environment auxSpec Coordinate Value Memory) (state : State Coordinate Value Memory)
+    (coordinate : Coordinate) (candidate : Value) (hit : Bool) : State Coordinate Value Memory :=
+  { allowed := restrict state.allowed coordinate candidate hit
+    retired := if hit then insert coordinate state.retired else state.retired
+    guesses := if hit = true ∧ coordinate ∉ state.retired then insert coordinate state.guesses else state.guesses
+    probes := state.probes + 1
+    memory := environment.trial state.memory coordinate candidate hit }
+
+def afterDisclosure (environment : Environment auxSpec Coordinate Value Memory) (state : State Coordinate Value Memory)
+    (coordinate : Coordinate) (value : Value) : State Coordinate Value Memory :=
+  { state with
+    allowed := discloseTableValue state.allowed coordinate value
+    retired := insert coordinate state.retired
+    memory := environment.disclosure state.memory coordinate value }
+
+noncomputable def fixedImpl (environment : Environment auxSpec Coordinate Value Memory) (labels : Coordinate → Value) :
+    QueryImpl (World auxSpec Coordinate Value) (StateT (State Coordinate Value Memory) SPMF)
+  | .inl input => StateT.mk fun state =>
+      (fun result => (result.1, { state with memory := result.2 })) <$> (liftM (environment.auxiliary state input) : SPMF _)
+  | .inr (.inl (coordinate, candidate)) => StateT.mk fun state =>
+      let hit := decide (labels coordinate = candidate)
+      pure (hit, afterTrial environment state coordinate candidate hit)
+  | .inr (.inr coordinate) => StateT.mk fun state =>
+      pure (labels coordinate, afterDisclosure environment state coordinate (labels coordinate))
+
+noncomputable def lazyImpl (environment : Environment auxSpec Coordinate Value Memory) :
+    QueryImpl (World auxSpec Coordinate Value) (StateT (State Coordinate Value Memory) SPMF)
+  | .inl input => StateT.mk fun state =>
+      (fun result => (result.1, { state with memory := result.2 })) <$> (liftM (environment.auxiliary state input) : SPMF _)
+  | .inr (.inl (coordinate, candidate)) => StateT.mk fun state =>
+      (fun hit => (hit, afterTrial environment state coordinate candidate hit)) <$> trial state.allowed coordinate candidate
+  | .inr (.inr coordinate) => StateT.mk fun state =>
+      (fun value => (value, afterDisclosure environment state coordinate value)) <$> cell (state.allowed coordinate)
+
+noncomputable def runWith {Result : Type}
+    (implementation : QueryImpl (World auxSpec Coordinate Value) (StateT (State Coordinate Value Memory) SPMF))
+    (computation : OracleComp (World auxSpec Coordinate Value) Result) (state : State Coordinate Value Memory) :
+    SPMF (Result × State Coordinate Value Memory) :=
+  (simulateQ implementation computation).run state
+
+noncomputable def fixedRun {Result : Type} (environment : Environment auxSpec Coordinate Value Memory)
+    (labels : Coordinate → Value) (computation : OracleComp (World auxSpec Coordinate Value) Result)
+    (state : State Coordinate Value Memory) := runWith (fixedImpl environment labels) computation state
+
+noncomputable def lazyRun {Result : Type} (environment : Environment auxSpec Coordinate Value Memory)
+    (computation : OracleComp (World auxSpec Coordinate Value) Result) (state : State Coordinate Value Memory) :=
+  runWith (lazyImpl environment) computation state
+
+def probeStep : (World auxSpec Coordinate Value).Domain → Nat
+  | .inr (.inl _) => 1
+  | _ => 0
+
+theorem lazyImpl_probes (environment : Environment auxSpec Coordinate Value Memory)
+    (state : State Coordinate Value Memory) (input : (World auxSpec Coordinate Value).Domain)
+    (result : (World auxSpec Coordinate Value).Range input × State Coordinate Value Memory)
+    (hr : (lazyImpl environment input).run state result ≠ 0) :
+    result.2.probes = state.probes + probeStep input := by
+  cases input with
+  | inl input =>
+      simp only [lazyImpl, StateT.run_mk, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero,
+        Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+      obtain ⟨answer, _, rfl⟩ := hr
+      exact (Nat.add_zero _).symm
+  | inr input =>
+      cases input with
+      | inl probe =>
+          rcases probe with ⟨coordinate, candidate⟩
+          simp only [lazyImpl, StateT.run_mk, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero,
+            Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+          obtain ⟨hit, _, rfl⟩ := hr
+          rfl
+      | inr coordinate =>
+          simp only [lazyImpl, StateT.run_mk, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero,
+            Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+          obtain ⟨value, _, rfl⟩ := hr
+          exact (Nat.add_zero _).symm
+
+omit [Fintype Coordinate] [DecidableEq Coordinate] [DecidableEq Value] in
+theorem runWith_pure {Result : Type}
+    (implementation : QueryImpl (World auxSpec Coordinate Value) (StateT (State Coordinate Value Memory) SPMF))
+    (result : Result) (state : State Coordinate Value Memory) :
+    runWith implementation (pure result) state = pure (result, state) := by
+  simp only [runWith, simulateQ_pure, StateT.run_pure]
+
+omit [Fintype Coordinate] [DecidableEq Coordinate] [DecidableEq Value] in
+theorem runWith_query_bind {Result : Type}
+    (implementation : QueryImpl (World auxSpec Coordinate Value) (StateT (State Coordinate Value Memory) SPMF))
+    (input : (World auxSpec Coordinate Value).Domain)
+    (next : (World auxSpec Coordinate Value).Range input → OracleComp (World auxSpec Coordinate Value) Result)
+    (state : State Coordinate Value Memory) :
+    runWith implementation (liftM ((World auxSpec Coordinate Value).query input) >>= next) state =
+      ((implementation input).run state >>= fun result => runWith implementation (next result.1) result.2) := by
+  simp only [runWith, simulateQ_bind, simulateQ_spec_query, StateT.run_bind]
+
+theorem run_posterior {Result : Type} (environment : Environment auxSpec Coordinate Value Memory)
+    (computation : OracleComp (World auxSpec Coordinate Value) Result) (state : State Coordinate Value Memory) :
+    (complete state.allowed >>= fun labels => (fun result => (labels, result)) <$> fixedRun environment labels computation state) =
+      (lazyRun environment computation state >>= fun result =>
+        (fun labels => (labels, result)) <$> complete result.2.allowed) := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure result => simp only [fixedRun, lazyRun, runWith_pure, pure_bind, ← bind_pure_comp]
+  | query_bind input next ih =>
+      cases input with
+      | inl input =>
+          simp only [fixedRun, lazyRun, runWith_query_bind, fixedImpl, lazyImpl,
+            StateT.run_mk, bind_map_left, map_bind, bind_assoc]
+          rw [RetainedObservation.bind_comm]
+          exact congrArg ((liftM (environment.auxiliary state input) : SPMF _) >>= ·)
+            (funext fun answer => ih answer.1 { state with memory := answer.2 })
+      | inr input =>
+          cases input with
+          | inl probe =>
+              rcases probe with ⟨coordinate, candidate⟩
+              simp only [fixedRun, lazyRun, runWith_query_bind, fixedImpl, lazyImpl,
+                StateT.run_mk, pure_bind, bind_map_left, bind_assoc]
+              rw [bind_trial state.allowed coordinate candidate (fun hit labels =>
+                (fun result => (labels, result)) <$> runWith (fixedImpl environment labels) (next hit)
+                  (afterTrial environment state coordinate candidate hit))]
+              exact congrArg (trial state.allowed coordinate candidate >>= ·)
+                (funext fun hit => ih hit (afterTrial environment state coordinate candidate hit))
+          | inr coordinate =>
+              simp only [fixedRun, lazyRun, runWith_query_bind, fixedImpl, lazyImpl,
+                StateT.run_mk, pure_bind, bind_map_left, bind_assoc]
+              rw [bind_disclose state.allowed coordinate (fun value labels =>
+                (fun result => (labels, result)) <$> runWith (fixedImpl environment labels) (next value)
+                  (afterDisclosure environment state coordinate value))]
+              exact congrArg (cell (state.allowed coordinate) >>= ·)
+                (funext fun value => ih value (afterDisclosure environment state coordinate value))
+
+theorem lazyRun_preserves {Result : Type} (environment : Environment auxSpec Coordinate Value Memory)
+    (invariant : State Coordinate Value Memory → Prop)
+    (hstep : ∀ state, invariant state → ∀ input result,
+      (lazyImpl environment input).run state result ≠ 0 → invariant result.2)
+    (computation : OracleComp (World auxSpec Coordinate Value) Result) (state : State Coordinate Value Memory)
+    (hinvariant : invariant state) (result : Result × State Coordinate Value Memory)
+    (hr : lazyRun environment computation state result ≠ 0) : invariant result.2 := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      simp only [lazyRun, runWith_pure, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+      subst result
+      exact hinvariant
+  | query_bind input next ih =>
+      rw [lazyRun, runWith_query_bind, RetainedObservation.bind_nonzero] at hr
+      obtain ⟨middle, hm, hr⟩ := hr
+      exact ih middle.1 middle.2 (hstep state hinvariant input middle hm) result hr
+
+theorem lazyRun_nonempty {Result : Type} (environment : Environment auxSpec Coordinate Value Memory)
+    (computation : OracleComp (World auxSpec Coordinate Value) Result) (state : State Coordinate Value Memory)
+    (ha : ∀ coordinate, (state.allowed coordinate).Nonempty) (result : Result × State Coordinate Value Memory)
+    (hr : lazyRun environment computation state result ≠ 0) : ∀ coordinate, (result.2.allowed coordinate).Nonempty := by
+  apply lazyRun_preserves environment (fun state => ∀ coordinate, (state.allowed coordinate).Nonempty) _ computation state ha result hr
+  intro state hs input result hr
+  cases input with
+  | inl input =>
+      simp only [lazyImpl, StateT.run_mk, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero,
+        Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+      obtain ⟨answer, _, rfl⟩ := hr
+      exact hs
+  | inr input =>
+      cases input with
+      | inl probe =>
+          rcases probe with ⟨coordinate, candidate⟩
+          simp only [lazyImpl, StateT.run_mk, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero,
+        Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+          obtain ⟨hit, hh, rfl⟩ := hr
+          exact trial_nonempty state.allowed coordinate candidate hit hh
+      | inr coordinate =>
+          simp only [lazyImpl, StateT.run_mk, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero,
+        Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+          obtain ⟨value, _, rfl⟩ := hr
+          exact discloseTableValue_nonempty state.allowed hs coordinate value
+
+theorem run_erasure {Result : Type} (environment : Environment auxSpec Coordinate Value Memory)
+    (computation : OracleComp (World auxSpec Coordinate Value) Result) (state : State Coordinate Value Memory)
+    (ha : ∀ coordinate, (state.allowed coordinate).Nonempty) :
+    (complete state.allowed >>= fun labels => fixedRun environment labels computation state) =
+      lazyRun environment computation state := by
+  have h := congrArg (Functor.map Prod.snd) (run_posterior environment computation state)
+  simp only [map_bind, Functor.map_map, id_map'] at h
+  calc
+    _ = lazyRun environment computation state >>= fun result =>
+        (fun _ => result) <$> complete result.2.allowed := h
+    _ = lazyRun environment computation state >>= pure := by
+      apply RetainedObservation.bind_congr
+      intro result hr
+      rw [complete_of_nonempty result.2.allowed (lazyRun_nonempty environment computation state ha result hr),
+        map_eq_bind_pure_comp]
+      exact RetainedObservation.lift_bind_const _ _
+    _ = _ := bind_pure _
+
+omit [Fintype Coordinate] in
+theorem restrict_false (allowed : Coordinate → Finset Value) (coordinate : Coordinate) (candidate : Value) :
+    restrict allowed coordinate candidate false = eraseTableValue allowed coordinate candidate := by
+  funext other
+  by_cases heq : other = coordinate
+  · subst other
+    rw [restrict, eraseTableValue, Function.update_self, Function.update_self]
+    ext value
+    by_cases hv : value = candidate
+    · simp [hv]
+    · simp [hv]
+  · simp only [restrict, eraseTableValue, Function.update_of_ne heq]
+
+omit [Fintype Coordinate] in
+theorem restrict_false_card (allowed : Coordinate → Finset Value) (coordinate : Coordinate) (candidate : Value)
+    (other : Coordinate) : (allowed other).card ≤ (restrict allowed coordinate candidate false other).card + 1 := by
+  rw [restrict_false]
+  by_cases heq : other = coordinate
+  · subst other
+    rw [eraseTableValue, Function.update_self]
+    have h := Finset.pred_card_le_card_erase (s := allowed coordinate) (a := candidate)
+    omega
+  · rw [eraseTableValue, Function.update_of_ne heq]
+    omega
+
+def Invariant (size : Nat) (state : State Coordinate Value Memory) : Prop :=
+  (∀ coordinate, coordinate ∉ state.retired → size ≤ (state.allowed coordinate).card + state.probes) ∧
+    state.guesses ⊆ state.retired
+
+omit [Fintype Coordinate] in
+theorem afterTrial_invariant (environment : Environment auxSpec Coordinate Value Memory)
+    (size : Nat) (state : State Coordinate Value Memory) (hs : Invariant size state)
+    (coordinate : Coordinate) (candidate : Value) (hit : Bool) :
+    Invariant size (afterTrial environment state coordinate candidate hit) := by
+  cases hit with
+  | false =>
+      constructor
+      · intro other ho
+        have hb := hs.1 other ho
+        have hc := restrict_false_card state.allowed coordinate candidate other
+        change size ≤ (restrict state.allowed coordinate candidate false other).card + (state.probes + 1)
+        omega
+      · simpa only [afterTrial, Bool.false_eq_true, false_and, if_false] using hs.2
+  | true =>
+      constructor
+      · intro other ho
+        have hn : other ≠ coordinate ∧ other ∉ state.retired := by
+          simpa only [afterTrial, if_true, Finset.mem_insert, not_or] using ho
+        have hb := hs.1 other hn.2
+        change size ≤ (restrict state.allowed coordinate candidate true other).card + (state.probes + 1)
+        rw [restrict, Function.update_of_ne hn.1]
+        omega
+      · simp only [afterTrial, if_true, true_and]
+        split
+        · exact Finset.insert_subset_insert coordinate hs.2
+        · exact hs.2.trans (Finset.subset_insert _ _)
+
+omit [Fintype Coordinate] [DecidableEq Value] in
+theorem afterDisclosure_invariant (environment : Environment auxSpec Coordinate Value Memory)
+    (size : Nat) (state : State Coordinate Value Memory) (hs : Invariant size state)
+    (coordinate : Coordinate) (value : Value) : Invariant size (afterDisclosure environment state coordinate value) := by
+  constructor
+  · intro other ho
+    have hn : other ≠ coordinate ∧ other ∉ state.retired := by
+      simpa only [afterDisclosure, Finset.mem_insert, not_or] using ho
+    change size ≤ (discloseTableValue state.allowed coordinate value other).card + state.probes
+    rw [discloseTableValue, Function.update_of_ne hn.1]
+    exact hs.1 other hn.2
+  · exact hs.2.trans (Finset.subset_insert _ _)
+
+theorem lazyRun_invariant {Result : Type} (environment : Environment auxSpec Coordinate Value Memory)
+    (size : Nat) (computation : OracleComp (World auxSpec Coordinate Value) Result)
+    (state : State Coordinate Value Memory) (hs : Invariant size state) (result : Result × State Coordinate Value Memory)
+    (hr : lazyRun environment computation state result ≠ 0) : Invariant size result.2 := by
+  apply lazyRun_preserves environment (Invariant size) _ computation state hs result hr
+  intro state hs input result hr
+  cases input with
+  | inl input =>
+      simp only [lazyImpl, StateT.run_mk, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero,
+        Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+      obtain ⟨answer, _, rfl⟩ := hr
+      exact hs
+  | inr input =>
+      cases input with
+      | inl probe =>
+          rcases probe with ⟨coordinate, candidate⟩
+          simp only [lazyImpl, StateT.run_mk, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero,
+            Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+          obtain ⟨hit, _, rfl⟩ := hr
+          exact afterTrial_invariant environment size state hs coordinate candidate hit
+      | inr coordinate =>
+          simp only [lazyImpl, StateT.run_mk, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero,
+            Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+          obtain ⟨value, _, rfl⟩ := hr
+          exact afterDisclosure_invariant environment size state hs coordinate value
+
+omit [Fintype Coordinate] in
+theorem afterTrial_guesses_card (environment : Environment auxSpec Coordinate Value Memory)
+    (state : State Coordinate Value Memory) (hs : state.guesses ⊆ state.retired)
+    (coordinate : Coordinate) (candidate : Value) (hit : Bool) :
+    (afterTrial environment state coordinate candidate hit).guesses.card =
+      state.guesses.card + if hit = true ∧ coordinate ∉ state.retired then 1 else 0 := by
+  by_cases hh : hit = true ∧ coordinate ∉ state.retired
+  · simp only [afterTrial, if_pos hh]
+    exact Finset.card_insert_of_notMem (fun hm => hh.2 (hs hm))
+  · simp only [afterTrial, if_neg hh, Nat.add_zero]
+
+theorem trial_true_le (size q : Nat) (state : State Coordinate Value Memory)
+    (hs : Invariant size state) (ha : ∀ coordinate, (state.allowed coordinate).Nonempty)
+    (hq : state.probes ≤ q) (coordinate : Coordinate) (hc : coordinate ∉ state.retired) (candidate : Value) :
+    trial state.allowed coordinate candidate true ≤ ((size - q : Nat) : ENNReal)⁻¹ := by
+  rw [trial_true state.allowed ha]
+  split
+  · apply ENNReal.inv_le_inv.mpr
+    have h := hs.1 coordinate hc
+    exact_mod_cast (show size - q ≤ (state.allowed coordinate).card by omega)
+  · exact bot_le
+
+def initialState [Fintype Value] (memory : Memory) : State Coordinate Value Memory :=
+  ⟨fun _ => Finset.univ, ∅, ∅, 0, memory⟩
+
+omit [Fintype Coordinate] [DecidableEq Coordinate] [DecidableEq Value] in
+theorem initialState_invariant [Fintype Value] (memory : Memory) :
+    Invariant (Fintype.card Value) (initialState (Coordinate := Coordinate) (Value := Value) memory) := by
+  simp [Invariant, initialState]
+
+def disclosure (coordinate : Coordinate) : OracleComp (World auxSpec Coordinate Value) Value :=
+  liftM ((World auxSpec Coordinate Value).query (.inr (.inr coordinate)))
+
+def disclosureSequenceState (environment : Environment auxSpec Coordinate Value Memory) (labels : Coordinate → Value)
+    {n : Nat} (coordinates : Fin n → Coordinate) (state : State Coordinate Value Memory) : State Coordinate Value Memory :=
+  (List.ofFn coordinates).foldl (fun state coordinate => afterDisclosure environment state coordinate (labels coordinate)) state
+
+omit [Fintype Coordinate] [DecidableEq Value] in
+theorem disclosureSequenceState_counts (environment : Environment auxSpec Coordinate Value Memory) (labels : Coordinate → Value)
+    {n : Nat} (coordinates : Fin n → Coordinate) (state : State Coordinate Value Memory) :
+    ((disclosureSequenceState environment labels coordinates state).guesses,
+      (disclosureSequenceState environment labels coordinates state).probes) = (state.guesses, state.probes) := by
+  unfold disclosureSequenceState
+  generalize List.ofFn coordinates = entries
+  induction entries generalizing state with
+  | nil => rfl
+  | cons coordinate entries ih => exact ih (afterDisclosure environment state coordinate (labels coordinate))
+
+omit [Fintype Coordinate] in
+theorem fixedRun_disclosureSequence_bind {Result : Type} (environment : Environment auxSpec Coordinate Value Memory)
+    (labels : Coordinate → Value) {n : Nat} (coordinates : Fin n → Coordinate)
+    (next : (Fin n → Value) → OracleComp (World auxSpec Coordinate Value) Result) (state : State Coordinate Value Memory) :
+    fixedRun environment labels ((sequenceFin fun index => disclosure (coordinates index)) >>= next) state =
+      fixedRun environment labels (next (fun index => labels (coordinates index)))
+        (disclosureSequenceState environment labels coordinates state) := by
+  induction n generalizing state with
+  | zero =>
+      have hv : (Fin.elim0 : Fin 0 → Value) = (fun index => labels (coordinates index)) := by
+        funext index
+        exact Fin.elim0 index
+      simp only [sequenceFin, pure_bind, hv, disclosureSequenceState, List.ofFn_zero, List.foldl_nil]
+  | succ n ih =>
+      rw [sequenceFin, bind_assoc]
+      change runWith (fixedImpl environment labels)
+        (liftM ((World auxSpec Coordinate Value).query (.inr (.inr (coordinates 0)))) >>= _) state = _
+      rw [runWith_query_bind]
+      simp only [fixedImpl, StateT.run_mk, pure_bind, bind_assoc]
+      change fixedRun environment labels
+        ((sequenceFin fun index => disclosure (coordinates index.succ)) >>=
+          fun tail => next (Fin.cons (labels (coordinates 0)) tail))
+        (afterDisclosure environment state (coordinates 0) (labels (coordinates 0))) = _
+      rw [ih]
+      have hv : Fin.cons (labels (coordinates 0)) (fun index => labels (coordinates index.succ)) =
+          (fun index => labels (coordinates index)) := by
+        funext index
+        cases index using Fin.cases <;> rfl
+      rw [hv]
+      simp only [disclosureSequenceState, List.ofFn_succ, List.foldl_cons]
+
+end SphincsSecurity.Concrete.SecretGuessObservation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessPairBound.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessPairBound.lean
new file mode 100644
index 000000000..bb6bde5d9
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/SecretGuessPairBound.lean
@@ -0,0 +1,145 @@
+import SphincsSecurity.Proof.Forced.SecretGuessObservation
+namespace SphincsSecurity.Concrete.SecretGuessObservation
+
+open _root_.OracleComp OracleSpec ENNReal
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def pairValue (rate : ENNReal) (remaining : Nat) : Nat → ENNReal
+  | 0 => remaining.choose 2 * rate ^ 2
+  | 1 => remaining * rate
+  | _ + 2 => 1
+
+theorem pairValue_mono (rate : ENNReal) (hits : Nat) {first second : Nat} (h : first ≤ second) :
+    pairValue rate first hits ≤ pairValue rate second hits := by
+  cases hits with
+  | zero => exact mul_le_mul' (by exact_mod_cast Nat.choose_le_choose 2 h) le_rfl
+  | succ hits =>
+      cases hits with
+      | zero => exact mul_le_mul' (by exact_mod_cast h) le_rfl
+      | succ hits => exact le_rfl
+
+private theorem expectation_const_le {Result : Type} (law : SPMF Result) (value : ENNReal) :
+    (∑' result, Pr[= result | law] * value) ≤ value := by
+  rw [ENNReal.tsum_mul_right]
+  exact mul_le_of_le_one_left' tsum_probOutput_le_one
+
+theorem pairValue_trial (law : SPMF Bool) (rate : ENNReal) (hrate : law true ≤ rate) (remaining hits : Nat) :
+    (∑' hit, Pr[= hit | law] * pairValue rate remaining (hits + if hit then 1 else 0)) ≤
+      pairValue rate (remaining + 1) hits := by
+  have hfalse : law false ≤ 1 := by
+    simpa only [SPMF.probOutput_eq_apply] using (show Pr[= false | law] ≤ 1 from probOutput_le_one)
+  cases hits with
+  | zero =>
+      simp only [tsum_fintype, Fintype.sum_bool, Bool.false_eq_true, if_false, if_true, Nat.zero_add,
+        pairValue, SPMF.probOutput_eq_apply]
+      calc
+        _ ≤ rate * (remaining * rate) + ((remaining.choose 2 : Nat) : ENNReal) * rate ^ 2 :=
+          add_le_add (mul_le_mul' hrate le_rfl) (mul_le_of_le_one_left' hfalse)
+        _ = _ := by
+          rw [Nat.choose_succ_succ, Nat.choose_one_right, Nat.cast_add]
+          ring
+  | succ hits =>
+      cases hits with
+      | zero =>
+          simp only [tsum_fintype, Fintype.sum_bool, Bool.false_eq_true, if_false, if_true, Nat.add_zero,
+            pairValue, SPMF.probOutput_eq_apply, mul_one]
+          calc
+            _ ≤ rate + (remaining : ENNReal) * rate := add_le_add hrate (mul_le_of_le_one_left' hfalse)
+            _ = _ := by rw [Nat.cast_add, Nat.cast_one]; ring
+      | succ hits =>
+          calc
+            _ = ∑' hit, Pr[= hit | law] * 1 := by
+              apply tsum_congr
+              intro hit
+              cases hit <;> rfl
+            _ ≤ 1 := expectation_const_le law 1
+
+variable {Coordinate Value Memory AuxIndex : Type} {auxSpec : OracleSpec AuxIndex}
+  [Fintype Coordinate] [DecidableEq Coordinate] [DecidableEq Value]
+
+noncomputable def pairPotential (size budget : Nat) (state : State Coordinate Value Memory) : ENNReal :=
+  if state.probes ≤ budget then pairValue ((size - budget : Nat) : ENNReal)⁻¹ (budget - state.probes) state.guesses.card else 0
+
+theorem pairPotential_afterTrial (environment : Environment auxSpec Coordinate Value Memory)
+    (size budget : Nat) (state : State Coordinate Value Memory) (hs : Invariant size state)
+    (ha : ∀ coordinate, (state.allowed coordinate).Nonempty) (coordinate : Coordinate) (candidate : Value) :
+    (∑' hit, Pr[= hit | trial state.allowed coordinate candidate] *
+      pairPotential size budget (afterTrial environment state coordinate candidate hit)) ≤ pairPotential size budget state := by
+  classical
+  by_cases hroom : state.probes < budget
+  · have hwithin : state.probes ≤ budget := Nat.le_of_lt hroom
+    have hafter : state.probes + 1 ≤ budget := hroom
+    have hremaining : budget - state.probes = (budget - (state.probes + 1)) + 1 := by omega
+    have hp (hit : Bool) : (afterTrial environment state coordinate candidate hit).probes = state.probes + 1 := rfl
+    simp only [pairPotential, hp, afterTrial_guesses_card environment state hs.2, if_pos hafter, if_pos hwithin]
+    by_cases hc : coordinate ∈ state.retired
+    · simp only [hc, not_true_eq_false, and_false, if_false, Nat.add_zero]
+      exact (expectation_const_le _ _).trans (pairValue_mono _ _ (Nat.sub_le_sub_left (by omega) _))
+    · simp only [hc, not_false_eq_true, and_true]
+      rw [hremaining]
+      exact pairValue_trial _ _ (trial_true_le size budget state hs ha hwithin coordinate hc candidate) _ _
+  · have hafter : ¬state.probes + 1 ≤ budget := by omega
+    simp only [pairPotential, afterTrial, if_neg hafter, mul_zero, tsum_zero]
+    exact bot_le
+
+theorem lazyImpl_pairPotential (environment : Environment auxSpec Coordinate Value Memory)
+    (size budget : Nat) (state : State Coordinate Value Memory) (hs : Invariant size state)
+    (ha : ∀ coordinate, (state.allowed coordinate).Nonempty) (input : (World auxSpec Coordinate Value).Domain) :
+    (∑' result, Pr[= result | (lazyImpl environment input).run state] * pairPotential size budget result.2) ≤
+      pairPotential size budget state := by
+  cases input with
+  | inl input =>
+      simp only [lazyImpl, StateT.run_mk, tsum_probOutput_map_mul]
+      exact expectation_const_le _ _
+  | inr input =>
+      cases input with
+      | inl probe =>
+          rcases probe with ⟨coordinate, candidate⟩
+          simp only [lazyImpl, StateT.run_mk, tsum_probOutput_map_mul]
+          exact pairPotential_afterTrial environment size budget state hs ha coordinate candidate
+      | inr coordinate =>
+          simp only [lazyImpl, StateT.run_mk, tsum_probOutput_map_mul]
+          exact expectation_const_le _ _
+
+theorem lazyRun_pairPotential {Result : Type} (environment : Environment auxSpec Coordinate Value Memory)
+    (size budget : Nat) (computation : OracleComp (World auxSpec Coordinate Value) Result)
+    (state : State Coordinate Value Memory) (hs : Invariant size state)
+    (ha : ∀ coordinate, (state.allowed coordinate).Nonempty) :
+    (∑' result, Pr[= result | lazyRun environment computation state] * pairPotential size budget result.2) ≤
+      pairPotential size budget state := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [lazyRun, runWith_pure, tsum_probOutput_pure_mul, le_refl]
+  | query_bind input next ih =>
+      rw [lazyRun, runWith_query_bind, tsum_probOutput_bind_mul]
+      apply le_trans _ (lazyImpl_pairPotential environment size budget state hs ha input)
+      apply ENNReal.tsum_le_tsum
+      intro middle
+      by_cases hm : (lazyImpl environment input).run state middle = 0
+      · simp only [SPMF.probOutput_eq_apply, hm, zero_mul, le_refl]
+      · have hrun : lazyRun environment (liftM ((World auxSpec Coordinate Value).query input)) state middle ≠ 0 := by
+          simpa only [lazyRun, runWith, simulateQ_spec_query] using hm
+        exact mul_le_mul' le_rfl (ih middle.1 middle.2
+          (lazyRun_invariant environment size _ state hs middle hrun) (lazyRun_nonempty environment _ state ha middle hrun))
+
+omit [Fintype Coordinate] [DecidableEq Coordinate] [DecidableEq Value] in
+theorem pairPotential_two (size budget : Nat) (state : State Coordinate Value Memory)
+    (hbudget : state.probes ≤ budget) (hhits : 2 ≤ state.guesses.card) : 1 ≤ pairPotential size budget state := by
+  rw [pairPotential, if_pos hbudget]
+  obtain ⟨hits, heq⟩ := Nat.exists_eq_add_of_le hhits
+  rw [heq, Nat.add_comm]
+  exact le_rfl
+
+theorem lazyRun_two_guesses [Fintype Value] [Nonempty Value] {Result : Type} (environment : Environment auxSpec Coordinate Value Memory)
+    (computation : OracleComp (World auxSpec Coordinate Value) Result) (memory : Memory) (budget : Nat)
+    (hbudget : ∀ result, lazyRun environment computation (initialState memory) result ≠ 0 → result.2.probes ≤ budget) :
+    Pr[fun result => 2 ≤ result.2.guesses.card | lazyRun environment computation (initialState memory)] ≤
+      (budget.choose 2 : ENNReal) * ((Fintype.card Value - budget : Nat) : ENNReal)⁻¹ ^ 2 := by
+  apply (probEvent_le_tsum_probOutput_mul_cost_of_mem_support _ _
+    (fun result => pairPotential (Fintype.card Value) budget result.2) ?_).trans
+      (lazyRun_pairPotential environment (Fintype.card Value) budget computation (initialState memory)
+        (initialState_invariant memory) (fun _ => Finset.univ_nonempty))
+  intro result hr htwo
+  apply pairPotential_two _ _ result.2 _ htwo
+  exact hbudget result (by simpa only [mem_support_iff, SPMF.probOutput_eq_apply] using hr)
+
+end SphincsSecurity.Concrete.SecretGuessObservation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Forced/Security127SmallBudgetArithmetic.lean b/formal/sphincs/SphincsSecurity/Proof/Forced/Security127SmallBudgetArithmetic.lean
new file mode 100644
index 000000000..ef1dd1866
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Forced/Security127SmallBudgetArithmetic.lean
@@ -0,0 +1,76 @@
+import SphincsSecurity.Proof.Fts.CertificateCacheExceptionGrowth
+namespace SphincsSecurity.Concrete
+
+open ENNReal
+
+/-- The per-slot bound on the forced FTS near-certificate probability at hash budget `budget`: fourteen omitted trees, each paying the average terminal certificate price, the cache exception and the proposal prefix exception. -/
+noncomputable def nearCertificateBound (budget : Nat) : ENNReal :=
+  14 * ((budget : ENNReal) * (((557 : ENNReal) / 14) / (2 ^ 128 : Nat)) +
+    ((budget : ENNReal) * certificateCacheExceptionRate + (2 ^ 700 : ENNReal)⁻¹))
+
+set_option exponentiation.threshold 1024
+
+private theorem smallRangeClosing (x : ℝ) (hlow : 1 / 2 ^ 128 ≤ x) (hhigh : x ≤ 3 / 16384) :
+    7 / 4 * x + 11 / 65536 * x + 1 / 2 ^ 700 + x ^ 2 * 2 +
+      16384 / 16381 * x * (557 * x + 14 * (x / 2 ^ 41) + 14 / 2 ^ 700) ≤ 2 * x := by
+  have hn : 0 ≤ x := le_trans (by positivity) hlow
+  have hsq : x * x ≤ x * (3 / 16384) := mul_le_mul_of_nonneg_left hhigh hn
+  have htail : (1 : ℝ) / 2 ^ 700 ≤ x / 2 ^ 572 := by
+    calc
+      (1 : ℝ) / 2 ^ 700 = (1 / 2 ^ 128) / 2 ^ 572 := by norm_num
+      _ ≤ x / 2 ^ 572 := div_le_div_of_nonneg_right hlow (by positivity)
+  norm_num at hsq htail ⊢
+  nlinarith [hsq, htail, hn, hlow, hhigh]
+
+theorem small_bound_le_security127 (q : Nat) (hq : 1 ≤ q) (hsmall : q ≤ 3 * 2 ^ 114) :
+    (7 / 4 : ENNReal) * ((q : ENNReal) / 2 ^ 128) + (q : ENNReal) * (11 / 2 ^ 144 : ENNReal) +
+      (2 ^ 700 : ENNReal)⁻¹ + ((q : ENNReal) / 2 ^ 128) ^ 2 / (2 * (1 - (q : ENNReal) / 2 ^ 128) ^ 2) +
+      ((2 ^ 128 - q : Nat) : ENNReal)⁻¹ * ((q : ENNReal) * nearCertificateBound q) ≤ (q : ENNReal) / 2 ^ 127 := by
+  have hx : (q : ENNReal) / 2 ^ 128 ≤ 3 / 16384 := by
+    apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp
+    rw [ENNReal.toReal_div, ENNReal.toReal_div, ENNReal.toReal_pow, ENNReal.toReal_natCast, ENNReal.toReal_ofNat,
+      ENNReal.toReal_ofNat, ENNReal.toReal_ofNat]
+    have hq' : (q : ℝ) ≤ 3 * 2 ^ 114 := by exact_mod_cast hsmall
+    rw [div_le_div_iff₀ (by positivity) (by positivity)]
+    nlinarith
+  have hhalf : (2 : ENNReal)⁻¹ ≤ 1 - (q : ENNReal) / 2 ^ 128 := by
+    refine le_trans ?_ (tsub_le_tsub_left hx 1)
+    apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp
+    rw [ENNReal.toReal_sub_of_le (by
+      apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp
+      norm_num [ENNReal.toReal_div]) (by finiteness)]
+    norm_num [ENNReal.toReal_div, ENNReal.toReal_inv]
+  have hsquare : ((q : ENNReal) / 2 ^ 128) ^ 2 / (2 * (1 - (q : ENNReal) / 2 ^ 128) ^ 2) ≤ ((q : ENNReal) / 2 ^ 128) ^ 2 * 2 := by
+    rw [ENNReal.div_le_iff_le_mul (Or.inr (by finiteness)) (Or.inl (by finiteness)), mul_assoc]
+    apply le_trans (le_of_eq (mul_one _).symm)
+    apply mul_le_mul' le_rfl
+    calc
+      (1 : ENNReal) = 2 * (2 * ((2 : ENNReal)⁻¹) ^ 2) := by
+        apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp
+        norm_num [ENNReal.toReal_mul, ENNReal.toReal_pow, ENNReal.toReal_inv]
+      _ ≤ _ := mul_le_mul' le_rfl (mul_le_mul' le_rfl (pow_le_pow_left' hhalf 2))
+  have hinv : ((2 ^ 128 - q : Nat) : ENNReal)⁻¹ ≤ (16381 * 2 ^ 114 : ENNReal)⁻¹ := by
+    apply ENNReal.inv_le_inv.mpr
+    have h : ((16381 * 2 ^ 114 : Nat) : ENNReal) ≤ ((2 ^ 128 - q : Nat) : ENNReal) := by
+      exact_mod_cast (show 16381 * 2 ^ 114 ≤ 2 ^ 128 - q by omega)
+    exact_mod_cast h
+  have hrate : nearCertificateBound q ≤
+      14 * ((q : ENNReal) * (((557 : ENNReal) / 14) / (2 ^ 128 : Nat)) +
+        ((q : ENNReal) * (2 ^ 169 : ENNReal)⁻¹ + (2 ^ 700 : ENNReal)⁻¹)) := by
+    unfold nearCertificateBound
+    gcongr
+    exact certificateCacheExceptionRate_le
+  refine le_trans (add_le_add (add_le_add le_rfl hsquare) (mul_le_mul' hinv (mul_le_mul' le_rfl hrate))) ?_
+  apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp
+  simp (disch := finiteness) only [ENNReal.toReal_add, ENNReal.toReal_mul, ENNReal.toReal_div, ENNReal.toReal_inv,
+    ENNReal.toReal_pow, ENNReal.toReal_natCast, ENNReal.toReal_ofNat, Nat.cast_pow, Nat.cast_ofNat]
+  have hlow : 1 / 2 ^ 128 ≤ (q : ℝ) / 2 ^ 128 := by
+    apply div_le_div_of_nonneg_right _ (by positivity)
+    exact_mod_cast hq
+  have hhigh : (q : ℝ) / 2 ^ 128 ≤ 3 / 16384 := by
+    have hq' : (q : ℝ) ≤ 3 * 2 ^ 114 := by exact_mod_cast hsmall
+    rw [div_le_div_iff₀ (by positivity) (by positivity)]
+    nlinarith
+  convert smallRangeClosing ((q : ℝ) / 2 ^ 128) hlow hhigh using 1 <;> ring
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/AdaptiveHiddenHazard.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/AdaptiveHiddenHazard.lean
new file mode 100644
index 000000000..c48a0d4b8
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/AdaptiveHiddenHazard.lean
@@ -0,0 +1,70 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.HiddenLabelProbe
+import SphincsSecurity.Proof.Residual.RetainedObservation
+namespace SphincsSecurity.Concrete.HiddenLabelObservation
+
+open _root_.OracleComp OracleSpec ENNReal UniformTableCompletion RetainedObservation
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+variable {Coordinate : Type} [Fintype Coordinate] [DecidableEq Coordinate]
+
+omit [Fintype Coordinate] [DecidableEq Coordinate] in
+theorem response_failure (labels : Coordinate → Digest) (probe : Probe Coordinate) :
+    (response labels probe).toPMF none =
+      Pr[fun answer => ¬probe.keep labels answer | PMF.uniformOfFintype HashOutput] := by
+  rw [response, toPMF_bind_lift, PMF.bind_apply, probEvent_eq_tsum_ite]
+  apply tsum_congr
+  intro answer
+  by_cases h : probe.keep labels answer
+  · simp only [h, if_true, not_true_eq_false, if_false, SPMF.toPMF_pure, PMF.pure_apply,
+      reduceCtorEq, mul_zero]
+  · simp only [h, if_false, not_false_eq_true, if_true, SPMF.toPMF_failure, PMF.pure_apply,
+      mul_one, PMF.probOutput_eq_apply]
+
+theorem lazyResponse_pair_failure (allowed : Coordinate → Finset Digest)
+    (ha : ∀ coordinate, (allowed coordinate).Nonempty) (child parent : Coordinate) (hne : child ≠ parent)
+    (candidate : Digest) :
+    (lazyResponse allowed (.pair child parent hne candidate)).toPMF none =
+      Pr[HiddenLabelProbe.Match child parent candidate | HiddenLabelProbe.law allowed ha] := by
+  rw [lazyResponse, complete_of_nonempty allowed ha, toPMF_bind_lift, PMF.bind_apply]
+  change _ = Pr[HiddenLabelProbe.Match child parent candidate |
+    (uniformTable allowed ha) >>= fun labels => (fun answer => (labels, answer)) <$> PMF.uniformOfFintype HashOutput]
+  rw [probEvent_bind_eq_tsum]
+  simp only [PMF.probOutput_eq_apply, probEvent_map]
+  apply tsum_congr
+  intro labels
+  apply congrArg (uniformTable allowed ha labels * ·)
+  rw [response_failure]
+  apply congrArg (fun event => Pr[event | PMF.uniformOfFintype HashOutput])
+  funext answer
+  apply propext
+  simp only [Probe.keep, HiddenLabelProbe.Match, Function.comp_def, not_and_or, not_not, eq_comm]
+
+theorem lazyResponse_pair_failure_le_rounds (allowed : Coordinate → Finset Digest)
+    (ha : ∀ coordinate, (allowed coordinate).Nonempty) (child parent : Coordinate) (hne : child ≠ parent)
+    (candidate : Digest) (rounds : Nat) (hmin : 2 ^ digestBits - rounds ≤ (allowed child).card) :
+    (lazyResponse allowed (.pair child parent hne candidate)).toPMF none ≤
+      1 - (1 - ((2 ^ digestBits - rounds : Nat) : ENNReal)⁻¹) ^ 2 := by
+  rw [lazyResponse_pair_failure allowed ha child parent hne candidate]
+  exact HiddenLabelProbe.prob_match_le_rounds allowed ha child parent candidate rounds hmin
+
+omit [Fintype Coordinate] [DecidableEq Coordinate] in
+theorem response_output_failure (labels : Coordinate → Digest) (parent : Coordinate) :
+    (response labels (.output parent)).toPMF none = (Fintype.card Digest : ENNReal)⁻¹ := by
+  rw [response_failure]
+  simpa only [Probe.keep, not_not, eq_comm] using HiddenLabelProbe.prob_truncate_eq (labels parent)
+
+theorem lazyResponse_output_failure (allowed : Coordinate → Finset Digest)
+    (ha : ∀ coordinate, (allowed coordinate).Nonempty) (parent : Coordinate) :
+    (lazyResponse allowed (.output parent)).toPMF none = (Fintype.card Digest : ENNReal)⁻¹ := by
+  simp only [lazyResponse, complete_of_nonempty allowed ha, toPMF_bind_lift, PMF.bind_apply,
+    response_output_failure, ENNReal.tsum_mul_right, PMF.tsum_coe, one_mul]
+
+end SphincsSecurity.Concrete.HiddenLabelObservation
+
+namespace SphincsSecurity.Concrete.AdaptiveHiddenLabels
+
+open _root_.OracleComp OracleSpec ENNReal HiddenLabelObservation
+
+end SphincsSecurity.Concrete.AdaptiveHiddenLabels
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/AdaptiveProposalWords.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/AdaptiveProposalWords.lean
new file mode 100644
index 000000000..bddf7fdb2
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/AdaptiveProposalWords.lean
@@ -0,0 +1,44 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.ProposalWordDistribution
+import SphincsSecurity.Proof.Fts.UniformProposalMoments
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp ENNReal
+
+theorem evalDist_sampleUniformProposalWord {α : Type} [SampleableType α] [Fintype α] [Nonempty α] (steps : Nat) :
+    𝒟[sampleUniformProposalWord α steps] =
+      (liftM (independentProposalWord (PMF.uniformOfFintype α) steps) : SPMF (List α)) := by
+  induction steps with
+  | zero => simp only [sampleUniformProposalWord, independentProposalWord, evalDist_pure]
+  | succ steps ih =>
+      simp only [sampleUniformProposalWord, evalDist_bind, evalDist_pure, evalDist_uniformSample, ih,
+        independentProposalWord, PMF.map, Function.comp_def, ← PMF.monad_bind_eq_bind, PMF.evalDist_eq]
+      simp only [← PMF.monad_pure_eq_pure, liftM_pure]
+
+noncomputable def targetProposalAcceptance : ENNReal := targetProposalOverhead⁻¹
+
+theorem targetProposalAcceptance_ne_zero : targetProposalAcceptance ≠ 0 := by
+  rw [targetProposalAcceptance, ENNReal.inv_ne_zero]
+  unfold targetProposalOverhead
+  finiteness
+
+theorem targetProposalAcceptance_lt_one : targetProposalAcceptance < 1 := by
+  rw [targetProposalAcceptance, ENNReal.inv_lt_one]
+  unfold targetProposalOverhead
+  apply (ENNReal.toReal_lt_toReal (by finiteness) (by finiteness)).mp
+  norm_num [ENNReal.toReal_div]
+
+theorem targetProposalAcceptance_cap {Ω : Type*} (record : PMF Ω) (label : Ω → Index)
+    (hbound : ∀ index, (record.map label) index ≤ targetProposalIndexRate) (index : Index) :
+    targetProposalAcceptance * (record.map label) index ≤ PMF.uniformOfFintype Index index := by
+  rw [PMF.uniformOfFintype_apply, targetProposalAcceptance]
+  calc
+    _ ≤ targetProposalOverhead⁻¹ * targetProposalIndexRate := mul_le_mul' le_rfl (hbound index)
+    _ = _ := by
+      have hpositive : 0 < targetProposalOverhead :=
+        zero_lt_one.trans (ENNReal.inv_lt_one.mp targetProposalAcceptance_lt_one)
+      rw [targetProposalIndexRate, ← mul_assoc,
+        ENNReal.inv_mul_cancel hpositive.ne'
+          (by unfold targetProposalOverhead; finiteness), one_mul]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/BankedCacheWeight.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/BankedCacheWeight.lean
new file mode 100644
index 000000000..0a34fa9fd
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/BankedCacheWeight.lean
@@ -0,0 +1,171 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CacheMessageWeight
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+
+noncomputable def certificateBankCount (bank : HashInput → Bool) : ENNReal :=
+  ∑' input, if bank input then 1 else 0
+
+theorem certificateBankCount_empty : certificateBankCount (fun _ => false) = 0 := by
+  simp [certificateBankCount]
+
+theorem one_le_certificateBankCount (bank : HashInput → Bool) (input : HashInput) (hbank : bank input = true) :
+    1 ≤ certificateBankCount bank := by
+  have h := ENNReal.le_tsum (f := fun input => if bank input then (1 : ENNReal) else 0) input
+  simpa only [certificateBankCount, hbank, if_true] using h
+
+noncomputable def bankedCacheWeight (parameter : PublicParameter)
+    (weight : HashInput → FewTimeView → ENNReal) (bank : HashInput → Bool)
+    (stopped : Bool) (cache : QueryCache HashSpec) : ENNReal :=
+  ∑' input, if bank input then 1 else if stopped then 0 else
+    cacheMessageEntryWeight parameter weight cache input
+
+theorem bankedCacheWeight_mono (parameter : PublicParameter)
+    (first second : HashInput → FewTimeView → ENNReal) (bank : HashInput → Bool)
+    (stopped : Bool) (cache : QueryCache HashSpec)
+    (hle : ∀ input target, first input target ≤ second input target) :
+    bankedCacheWeight parameter first bank stopped cache ≤ bankedCacheWeight parameter second bank stopped cache := by
+  apply ENNReal.tsum_le_tsum
+  intro input
+  split_ifs
+  · exact le_rfl
+  · exact le_rfl
+  · unfold cacheMessageEntryWeight
+    cases cache input
+    · exact le_rfl
+    · simp only
+      split_ifs
+      · exact hle input _
+      · exact le_rfl
+
+theorem bankedCacheWeight_discard_le (parameter : PublicParameter)
+    (weight : HashInput → FewTimeView → ENNReal) (bank : HashInput → Bool)
+    (stopped : Bool) (cache : QueryCache HashSpec) :
+    bankedCacheWeight parameter weight bank stopped cache ≤ bankedCacheWeight parameter weight bank false cache := by
+  apply ENNReal.tsum_le_tsum
+  intro input
+  cases bank input <;> cases stopped <;> simp
+
+theorem certificateBankCount_le_bankedCacheWeight (parameter : PublicParameter)
+    (weight : HashInput → FewTimeView → ENNReal) (bank : HashInput → Bool)
+    (stopped : Bool) (cache : QueryCache HashSpec) :
+    certificateBankCount bank ≤ bankedCacheWeight parameter weight bank stopped cache := by
+  apply ENNReal.tsum_le_tsum
+  intro input
+  split_ifs <;> first | exact le_rfl | exact zero_le
+
+theorem bankedCacheWeight_stopped (parameter : PublicParameter)
+    (weight : HashInput → FewTimeView → ENNReal) (bank : HashInput → Bool)
+    (cache : QueryCache HashSpec) :
+    bankedCacheWeight parameter weight bank true cache = certificateBankCount bank := by
+  simp only [bankedCacheWeight, certificateBankCount, if_true]
+
+theorem bankedCacheWeight_live (parameter : PublicParameter)
+    (weight : HashInput → FewTimeView → ENNReal) (bank : HashInput → Bool)
+    (cache : QueryCache HashSpec) :
+    bankedCacheWeight parameter weight bank false cache = certificateBankCount bank +
+      cacheMessageWeight parameter (fun input target => if bank input then 0 else weight input target) cache := by
+  rw [bankedCacheWeight, certificateBankCount, cacheMessageWeight, ← ENNReal.tsum_add]
+  apply tsum_congr
+  intro input
+  cases hbank : bank input <;> cases hcache : cache input <;>
+    simp [cacheMessageEntryWeight, hbank, hcache]
+
+theorem bankedCacheWeight_bank_le (parameter : PublicParameter)
+    (weight : HashInput → FewTimeView → ENNReal) (bank completed : HashInput → Bool)
+    (stopped : Bool) (cache : QueryCache HashSpec)
+    (hcompleted : ∀ input, completed input = true →
+      1 ≤ cacheMessageEntryWeight parameter weight cache input) :
+    bankedCacheWeight parameter weight (fun input => bank input || completed input) stopped cache ≤
+      bankedCacheWeight parameter weight bank false cache := by
+  apply ENNReal.tsum_le_tsum
+  intro input
+  cases hbank : bank input <;> cases hcomplete : completed input <;>
+    simp only [hbank, hcomplete, Bool.false_or, Bool.true_or, Bool.false_eq_true, if_true, if_false, le_refl]
+  · cases stopped <;> simp
+  · exact hcompleted input hcomplete
+
+theorem expected_bankedCacheWeight_step_le_of_split {α : Type} (parameter : PublicParameter)
+    (computation : ProbComp α) (before : QueryCache HashSpec) (after : α → QueryCache HashSpec)
+    (weight : α → HashInput → FewTimeView → ENNReal)
+    (initial : HashInput → FewTimeView → ENNReal) (bank : HashInput → Bool)
+    (completed : α → HashInput → Bool) (stopped : α → Bool) (charge : ENNReal)
+    (hsplit : ∀ result ∈ support computation, ∀ value : HashInput → FewTimeView → ENNReal,
+      cacheMessageWeight parameter value (after result) = cacheMessageWeight parameter value before +
+        cacheMessageWeight parameter (fun input target => if before input = none then value input target else 0) (after result))
+    (hcompleted : ∀ result ∈ support computation, ∀ input, completed result input = true →
+      1 ≤ cacheMessageEntryWeight parameter (weight result) (after result) input)
+    (hold : ∀ input target, (∑' result, Pr[= result | computation] * weight result input target) ≤ initial input target)
+    (hnew : (∑' result, Pr[= result | computation] *
+      cacheMessageWeight parameter (fun input target => if before input = none then weight result input target else 0)
+        (after result)) ≤ charge) :
+    (∑' result, Pr[= result | computation] *
+      bankedCacheWeight parameter (weight result) (fun input => bank input || completed result input)
+        (stopped result) (after result)) ≤ bankedCacheWeight parameter initial bank false before + charge := by
+  let pending := fun result input target => if bank input then 0 else weight result input target
+  have hstep (result : α) (hr : result ∈ support computation) :
+      bankedCacheWeight parameter (weight result) (fun input => bank input || completed result input)
+        (stopped result) (after result) ≤
+      certificateBankCount bank + cacheMessageWeight parameter (pending result) before +
+        cacheMessageWeight parameter (fun input target => if before input = none then weight result input target else 0)
+          (after result) := by
+    apply (bankedCacheWeight_bank_le parameter (weight result) bank (completed result) (stopped result)
+      (after result) (hcompleted result hr)).trans
+    rw [bankedCacheWeight_live, hsplit result hr (pending result), ← add_assoc]
+    apply add_le_add le_rfl
+    apply cacheMessageWeight_mono
+    intro input target
+    dsimp only [pending]
+    split_ifs <;> first | exact le_rfl | exact zero_le
+  have hold' : (∑' result, Pr[= result | computation] * cacheMessageWeight parameter (pending result) before) ≤
+      cacheMessageWeight parameter (fun input target => if bank input then 0 else initial input target) before := by
+    rw [expected_cacheMessageWeight]
+    apply cacheMessageWeight_mono
+    intro input target
+    dsimp only [pending]
+    cases hb : bank input
+    · simpa only [hb, Bool.false_eq_true, if_false] using hold input target
+    · simp only [if_true, mul_zero, tsum_zero, le_refl]
+  calc
+    _ ≤ ∑' result, Pr[= result | computation] *
+        (certificateBankCount bank + cacheMessageWeight parameter (pending result) before +
+          cacheMessageWeight parameter (fun input target => if before input = none then weight result input target else 0)
+            (after result)) := by
+      apply ENNReal.tsum_le_tsum
+      intro result
+      by_cases hr : result ∈ support computation
+      · exact mul_le_mul' le_rfl (hstep result hr)
+      · rw [probOutput_eq_zero_of_not_mem_support hr, zero_mul, zero_mul]
+    _ = (∑' result, Pr[= result | computation]) * certificateBankCount bank +
+        (∑' result, Pr[= result | computation] * cacheMessageWeight parameter (pending result) before) +
+        (∑' result, Pr[= result | computation] *
+          cacheMessageWeight parameter (fun input target => if before input = none then weight result input target else 0)
+            (after result)) := by
+      simp only [mul_add, ENNReal.tsum_add, ENNReal.tsum_mul_right]
+    _ ≤ certificateBankCount bank +
+        cacheMessageWeight parameter (fun input target => if bank input then 0 else initial input target) before + charge :=
+      add_le_add (add_le_add (mul_le_of_le_one_left' tsum_probOutput_le_one) hold') hnew
+    _ = _ := by rw [bankedCacheWeight_live]
+
+theorem expected_bankedCacheWeight_step_le {α : Type} (parameter : PublicParameter)
+    (computation : ProbComp α) (before : QueryCache HashSpec) (after : α → QueryCache HashSpec)
+    (weight : α → HashInput → FewTimeView → ENNReal)
+    (initial : HashInput → FewTimeView → ENNReal) (bank : HashInput → Bool)
+    (completed : α → HashInput → Bool) (stopped : α → Bool) (charge : ENNReal)
+    (hcache : ∀ result ∈ support computation, before ≤ after result)
+    (hcompleted : ∀ result ∈ support computation, ∀ input, completed result input = true →
+      1 ≤ cacheMessageEntryWeight parameter (weight result) (after result) input)
+    (hold : ∀ input target, (∑' result, Pr[= result | computation] * weight result input target) ≤ initial input target)
+    (hnew : (∑' result, Pr[= result | computation] *
+      cacheMessageWeight parameter (fun input target => if before input = none then weight result input target else 0)
+        (after result)) ≤ charge) :
+    (∑' result, Pr[= result | computation] *
+      bankedCacheWeight parameter (weight result) (fun input => bank input || completed result input)
+        (stopped result) (after result)) ≤ bankedCacheWeight parameter initial bank false before + charge :=
+  expected_bankedCacheWeight_step_le_of_split parameter computation before after weight initial bank completed stopped charge
+    (fun result hr value => cacheMessageWeight_of_le parameter value before (after result) (hcache result hr))
+    hcompleted hold hnew
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/BankedProposalStep.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/BankedProposalStep.lean
new file mode 100644
index 000000000..f4001a0c9
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/BankedProposalStep.lean
@@ -0,0 +1,162 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.BankedTargetEnvelope
+import SphincsSecurity.Proof.Fts.OriginalProposalExecution
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+
+def proposalRecordLogState (input : (OracleWorld + SigningSpec).Domain) (log : QueryLog SigningSpec)
+    (record : ProposalExecutionRecord input) : CoverLogState :=
+  (record.cache, log ++ signingLogFragment input record.output)
+
+private theorem expected_pmfLift {α : Type} (computation : ProbComp α) (weight : α → ENNReal) :
+    (∑' result, Pr[= result | (liftM computation : PMF α)] * weight result) =
+      ∑' result, Pr[= result | computation] * weight result := rfl
+
+private theorem expected_pmf_mono_of_support {α : Type} (law : PMF α) (first second : α → ENNReal)
+    (hle : ∀ result ∈ law.support, first result ≤ second result) :
+    (∑' result, Pr[= result | law] * first result) ≤ ∑' result, Pr[= result | law] * second result := by
+  apply ENNReal.tsum_le_tsum
+  intro result
+  by_cases hr : result ∈ law.support
+  · exact mul_le_mul' le_rfl (hle result hr)
+  · have hp : Pr[= result | law] = 0 := by
+      rw [PMF.probOutput_eq_apply, PMF.apply_eq_zero_iff]
+      exact hr
+    rw [hp, zero_mul, zero_mul]
+
+theorem originalAdversaryPMFImpl_run (key : SecretKey) (input : (OracleWorld + SigningSpec).Domain)
+    (cache : QueryCache HashSpec) :
+    (originalAdversaryPMFImpl key input).run cache =
+      (liftM ((unloggedMappedAdversaryImpl key input).run cache) : PMF _) := by
+  rw [originalAdversaryPMFImpl, pmfSumImpl_eq_lift_add, originalAdversaryImpl_split]
+  rfl
+
+theorem expected_originalProposalRecord_logged (key : SecretKey) (input : (OracleWorld + SigningSpec).Domain)
+    (state : CoverLogState) (weight : CoverLogState → ENNReal) :
+    (∑' record, Pr[= record | originalProposalRecord key input state.1] *
+      weight (proposalRecordLogState input state.2 record)) =
+      ∑' result, Pr[= result | (logTracedMappedAdversaryImpl key input).run state] * weight result.2 := by
+  rw [logTracedMappedAdversaryImpl_run_map, tsum_probOutput_map_mul]
+  have h := congrArg (fun computation : PMF ((OracleWorld + SigningSpec).Range input × QueryCache HashSpec) =>
+    ∑' result, Pr[= result | computation] * weight (result.2, state.2 ++ signingLogFragment input result.1))
+      (originalProposalRecord_project key input state.1)
+  rw [← PMF.monad_map_eq_map, tsum_probOutput_map_mul, originalAdversaryPMFImpl_run, expected_pmfLift] at h
+  exact h
+
+theorem originalProposalRecord_world_hashCalls (key : SecretKey) (input : OracleWorld.Domain)
+    (cache : QueryCache HashSpec) (record : ProposalExecutionRecord (.inl input))
+    (hr : record ∈ (originalProposalRecord key (.inl input) cache).support) :
+    record.trace.hashCalls = signingExecutionHashCost (.inl input) := by
+  rw [originalProposalRecord, PMF.mem_support_map_iff] at hr
+  obtain ⟨result, _, rfl⟩ := hr
+  cases input with
+  | inl sample => rfl
+  | inr input => rfl
+
+noncomputable def bankedProposalRecordValue (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat)
+    (required : Finset FtsTree) (state : CoverLogState) (bank : HashInput → Bool)
+    (input : (OracleWorld + SigningSpec).Domain) (record : ProposalExecutionRecord input) (stopped : Bool) : ENNReal :=
+  let after := proposalRecordLogState input state.2 record
+  bankedTargetEnvelope key reuse (budget - record.trace.hashCalls) signatures required after
+    (completedTargetBank key required after bank) stopped
+
+theorem expected_originalProposalRecord_world_banked_le (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat)
+    (required : Finset FtsTree) (state : CoverLogState) (bank : HashInput → Bool) (input : OracleWorld.Domain)
+    (stopped : ProposalExecutionRecord (.inl input) → Bool)
+    (hsigned : SigningDigestsCached key.parameter state.1 key.root state.2)
+    (hcost : signingExecutionHashCost (.inl input) ≤ budget) :
+    (∑' record, Pr[= record | originalProposalRecord key (.inl input) state.1] *
+      bankedProposalRecordValue key reuse budget signatures required state bank (.inl input) record (stopped record)) ≤
+      bankedTargetEnvelope key reuse budget signatures required state bank false +
+        targetCreationMultiplier key state.1 (.inl input) * targetCreationPrice key reuse budget signatures required state := by
+  let afterBudget := budget - signingExecutionHashCost (.inl input)
+  let weight := fun current => bankedTargetEnvelope key reuse afterBudget signatures required current
+    (completedTargetBank key required current bank) false
+  have hstep := expected_logTraced_world_bankedTarget_le key reuse afterBudget signatures required state bank input
+    (fun _ => false) hsigned
+  have hrestore : afterBudget + signingExecutionHashCost (.inl input) = budget := Nat.sub_add_cancel hcost
+  rw [hrestore] at hstep
+  calc
+    _ ≤ ∑' record, Pr[= record | originalProposalRecord key (.inl input) state.1] *
+        weight (proposalRecordLogState (.inl input) state.2 record) := by
+      apply expected_pmf_mono_of_support
+      intro record hr
+      have hc := originalProposalRecord_world_hashCalls key input state.1 record hr
+      dsimp only [bankedProposalRecordValue, weight, afterBudget]
+      rw [hc]
+      exact bankedCacheWeight_discard_le _ _ _ _ _
+    _ = ∑' result, Pr[= result | (logTracedMappedAdversaryImpl key (.inl input)).run state] * weight result.2 :=
+      expected_originalProposalRecord_logged key (.inl input) state weight
+    _ ≤ bankedTargetEnvelope key reuse budget signatures required state bank false +
+        targetCreationMultiplier key state.1 (.inl input) * targetCreationPrice key reuse afterBudget signatures required state := by
+      simpa only [targetCreationMultiplier, targetCreationPrice, mul_assoc] using hstep
+    _ ≤ _ := add_le_add le_rfl (mul_le_mul' le_rfl
+      (targetCreationPrice_budget_mono key reuse signatures required state (Nat.sub_le _ _)))
+
+theorem expected_originalProposalRecord_sign_banked_le (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat)
+    (required : Finset FtsTree) (state : CoverLogState) (bank : HashInput → Bool) (message : Message)
+    (stopped : ProposalExecutionRecord (.inr message) → Bool)
+    (hsigned : SigningDigestsCached key.parameter state.1 key.root state.2)
+    (hreuse : exactDigestReuseWeight key message state.1 ≤ reuse) :
+    (∑' record, Pr[= record | originalProposalRecord key (.inr message) state.1] *
+      bankedProposalRecordValue key reuse budget signatures required state bank (.inr message) record (stopped record)) ≤
+      bankedTargetEnvelope key reuse budget (signatures + 1) required state bank false +
+        targetCreationMultiplier key state.1 (.inr message) * targetCreationPrice key reuse budget (signatures + 1) required state := by
+  let weight := fun current => bankedTargetEnvelope key reuse budget signatures required current
+    (completedTargetBank key required current bank) false
+  have hstep := expected_logTraced_sign_bankedTarget_le key reuse budget signatures required state bank message
+    (fun _ => false) hsigned hreuse
+  rw [← targetCreationMultiplier_sign_mul_price] at hstep
+  calc
+    _ ≤ ∑' record, Pr[= record | originalProposalRecord key (.inr message) state.1] *
+        weight (proposalRecordLogState (.inr message) state.2 record) := by
+      apply ENNReal.tsum_le_tsum
+      intro record
+      apply mul_le_mul' le_rfl
+      exact (bankedCacheWeight_discard_le _ _ _ _ _).trans
+        (bankedTargetEnvelope_budget_mono key reuse signatures required _ _ false (Nat.sub_le _ _))
+    _ = ∑' result, Pr[= result | (logTracedMappedAdversaryImpl key (.inr message)).run state] * weight result.2 :=
+      expected_originalProposalRecord_logged key (.inr message) state weight
+    _ ≤ bankedTargetEnvelope key reuse budget (signatures + 1) required state bank false +
+        targetCreationMultiplier key state.1 (.inr message) * targetCreationPrice key reuse budget signatures required state := hstep
+    _ ≤ _ := add_le_add le_rfl (mul_le_mul' le_rfl
+      (targetCreationPrice_signatures_mono key reuse budget required state (Nat.le_succ _)))
+
+theorem expected_coupled_bankedProposalRecord_le {α : Type}
+    (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat) (required : Finset FtsTree)
+    (state : CoverLogState) (bank : HashInput → Bool) (input : (OracleWorld + SigningSpec).Domain)
+    (law : PMF α) (record : α → ProposalExecutionRecord input) (stopped : α → Bool) (bound : ENNReal)
+    (hrecord : law.map record = originalProposalRecord key input state.1)
+    (hbound : (∑' result, Pr[= result | originalProposalRecord key input state.1] *
+      bankedProposalRecordValue key reuse budget signatures required state bank input result false) ≤ bound) :
+    (∑' result, Pr[= result | law] *
+      bankedProposalRecordValue key reuse budget signatures required state bank input (record result) (stopped result)) ≤ bound := by
+  calc
+    _ ≤ ∑' result, Pr[= result | law] *
+        bankedProposalRecordValue key reuse budget signatures required state bank input (record result) false := by
+      apply ENNReal.tsum_le_tsum
+      intro result
+      exact mul_le_mul' le_rfl (bankedCacheWeight_discard_le _ _ _ _ _)
+    _ = ∑' result, Pr[= result | originalProposalRecord key input state.1] *
+        bankedProposalRecordValue key reuse budget signatures required state bank input result false := by
+      rw [← hrecord, ← PMF.monad_map_eq_map, tsum_probOutput_map_mul]
+    _ ≤ bound := hbound
+
+theorem expected_lengthBridge_sign_banked_le (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat)
+    (required : Finset FtsTree) (state : CoverLogState) (bank : HashInput → Bool) (message : Message)
+    (stopped : Nat × ProposalExecutionRecord (.inr message) → Bool)
+    (hsigned : SigningDigestsCached key.parameter state.1 key.root state.2)
+    (hreuse : exactDigestReuseWeight key message state.1 ≤ reuse) :
+    (∑' result, Pr[= result | recordLengthBridge (originalProposalRecord key (.inr message) state.1)
+        targetProposalAcceptance targetProposalAcceptance_ne_zero targetProposalAcceptance_lt_one.le] *
+      bankedProposalRecordValue key reuse budget signatures required state bank (.inr message) result.2 (stopped result)) ≤
+      bankedTargetEnvelope key reuse budget (signatures + 1) required state bank false +
+        targetCreationMultiplier key state.1 (.inr message) * targetCreationPrice key reuse budget (signatures + 1) required state :=
+  expected_coupled_bankedProposalRecord_le key reuse budget signatures required state bank (.inr message)
+    _ Prod.snd stopped _ (recordLengthBridge_record _ _ _ _)
+    (expected_originalProposalRecord_sign_banked_le key reuse budget signatures required state bank message
+      (fun _ => false) hsigned hreuse)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/BankedTargetEnvelope.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/BankedTargetEnvelope.lean
new file mode 100644
index 000000000..b685a5769
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/BankedTargetEnvelope.lean
@@ -0,0 +1,220 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.BankedCacheWeight
+import SphincsSecurity.Proof.Fts.ReuseCachedTargets
+import SphincsSecurity.Proof.Fts.ReuseTargetEnvelope
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (MessageHashInput messageAnswers)
+attribute [local instance] Classical.propDecidable
+
+def TargetCoveredOn (key : SecretKey) (required : Finset FtsTree) (state : CoverLogState)
+    (payload : HashInput) (target : FewTimeView) : Prop :=
+  ∀ tree ∈ required, 0 < targetTreeMatchCount
+    (eligibleSigningViews (messageAnswers key.parameter state.1) key.root payload state.2) target tree
+
+def TargetCertificateAt (key : SecretKey) (required : Finset FtsTree) (state : CoverLogState)
+    (input : HashInput) : Prop :=
+  ∃ output, state.1 input = some output ∧ MessageHashInput key.parameter input ∧
+    Admissible (truncateMessageDigest output) ∧
+      TargetCoveredOn key required state (payloadOf input) (hashOutputFewTimeView output)
+
+noncomputable def completedTargetBank (key : SecretKey) (required : Finset FtsTree)
+    (state : CoverLogState) (bank : HashInput → Bool) : HashInput → Bool :=
+  fun input => bank input || decide (TargetCertificateAt key required state input)
+
+noncomputable def targetCertificateScale (required : Finset FtsTree) : ENNReal :=
+  ((Fintype.card FtsLeaf : ENNReal) ^ required.card)⁻¹
+
+noncomputable def targetCertificateForecast (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat)
+    (required : Finset FtsTree) (state : CoverLogState) (input : HashInput) (target : FewTimeView) : ENNReal :=
+  reuseTargetEnvelope key reuse budget (payloadOf input) target signatures state ∅ required *
+    targetCertificateScale required
+
+noncomputable def bankedTargetEnvelope (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat)
+    (required : Finset FtsTree) (state : CoverLogState) (bank : HashInput → Bool) (stopped : Bool) : ENNReal :=
+  bankedCacheWeight key.parameter (targetCertificateForecast key reuse budget signatures required state) bank stopped state.1
+
+noncomputable def targetCreationMultiplier (key : SecretKey) (cache : QueryCache HashSpec) :
+    (OracleWorld + SigningSpec).Domain → ENNReal
+  | .inl input => freshWorldTargetHashCost key.parameter cache input
+  | .inr message => ((2 ^ ftsTreeHeight : Nat) : ENNReal) * freshDigestSelectionProbability key message cache
+
+noncomputable def targetCreationPrice (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat)
+    (required : Finset FtsTree) (state : CoverLogState) : ENNReal :=
+  (((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ * (Fintype.card Index : ENNReal)⁻¹) *
+    reuseRawEnvelope key reuse budget signatures state ∅ required * targetCertificateScale required
+
+theorem bankedTargetEnvelope_initial (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat)
+    (required : Finset FtsTree) (state : CoverLogState)
+    (hnone : ∀ input, MessageHashInput key.parameter input → state.1 input = none) :
+    bankedTargetEnvelope key reuse budget signatures required state (fun _ => false) false = 0 := by
+  rw [bankedTargetEnvelope, bankedCacheWeight_live, certificateBankCount_empty, zero_add]
+  exact cacheMessageWeight_of_no_message key.parameter _ state.1 hnone
+
+theorem bankedTargetEnvelope_stopped (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat)
+    (required : Finset FtsTree) (state : CoverLogState) (bank : HashInput → Bool) :
+    bankedTargetEnvelope key reuse budget signatures required state bank true = certificateBankCount bank :=
+  bankedCacheWeight_stopped _ _ _ _
+
+theorem targetCreationMultiplier_sign_mul_price (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat)
+    (required : Finset FtsTree) (state : CoverLogState) (message : Message) :
+    targetCreationMultiplier key state.1 (.inr message) * targetCreationPrice key reuse budget signatures required state =
+      freshDigestSelectionProbability key message state.1 *
+        ((Fintype.card Index : ENNReal)⁻¹ * reuseRawEnvelope key reuse budget signatures state ∅ required) *
+          targetCertificateScale required := by
+  have hcancel : ((2 ^ ftsTreeHeight : Nat) : ENNReal) * ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ = 1 :=
+    ENNReal.mul_inv_cancel (by norm_num [ftsTreeHeight]) (by finiteness)
+  unfold targetCreationMultiplier targetCreationPrice
+  calc
+    _ = (((2 ^ ftsTreeHeight : Nat) : ENNReal) * ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹) *
+        (freshDigestSelectionProbability key message state.1 *
+          ((Fintype.card Index : ENNReal)⁻¹ * reuseRawEnvelope key reuse budget signatures state ∅ required) *
+            targetCertificateScale required) := by ring
+    _ = _ := by rw [hcancel, one_mul]
+
+theorem completedTargetBank_of_certificate (key : SecretKey) (required : Finset FtsTree)
+    (state : CoverLogState) (bank : HashInput → Bool) (input : HashInput)
+    (hcovered : TargetCertificateAt key required state input) :
+    completedTargetBank key required state bank input = true := by
+  simp only [completedTargetBank, hcovered, decide_true, Bool.or_true]
+
+theorem normalizedTargetLogProduct_ge_of_coveredOn (key : SecretKey) (required : Finset FtsTree)
+    (state : CoverLogState) (payload : HashInput) (target : FewTimeView)
+    (hcovered : TargetCoveredOn key required state payload target) :
+    (Fintype.card FtsLeaf : ENNReal) ^ required.card ≤
+      normalizedTargetLogProduct key state.1 state.2 payload target required := by
+  rw [← Finset.prod_const]
+  apply Finset.prod_le_prod'
+  intro tree htree
+  apply le_mul_of_one_le_right'
+  exact_mod_cast Nat.succ_le_iff.mpr (hcovered tree htree)
+
+theorem one_le_targetCertificateForecast_of_covered (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat)
+    (required : Finset FtsTree) (state : CoverLogState) (input : HashInput) (target : FewTimeView)
+    (hcovered : TargetCoveredOn key required state (payloadOf input) target) :
+    1 ≤ targetCertificateForecast key reuse budget signatures required state input target := by
+  have hmoment := normalizedTargetLogProduct_ge_of_coveredOn key required state (payloadOf input) target hcovered
+  have hforecast : (Fintype.card FtsLeaf : ENNReal) ^ required.card ≤
+      reuseTargetEnvelope key reuse budget (payloadOf input) target signatures state ∅ required := by
+    apply hmoment.trans
+    simpa only [reuseTargetEnvelope, observedTargetShapeVector, targetShapeMoments, Finset.prod_empty, one_mul] using
+      (le_targetShapeEnvelope (Fintype.card Index : ENNReal)⁻¹ reuse
+        (((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ * (Fintype.card Index : ENNReal)⁻¹)
+        budget signatures (observedTargetShapeVector key (payloadOf input) target state) ∅ required)
+  have hzero : (Fintype.card FtsLeaf : ENNReal) ^ required.card ≠ 0 :=
+    pow_ne_zero _ (by norm_num [FtsLeaf, ftsTreeHeight])
+  have hfinite : (Fintype.card FtsLeaf : ENNReal) ^ required.card ≠ ∞ := by finiteness
+  unfold targetCertificateForecast targetCertificateScale
+  rw [← ENNReal.mul_inv_cancel hzero hfinite]
+  exact mul_le_mul' hforecast le_rfl
+
+theorem one_le_targetCertificateEntry_of_certificate (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat)
+    (required : Finset FtsTree) (state : CoverLogState) (input : HashInput)
+    (hcertificate : TargetCertificateAt key required state input) :
+    1 ≤ cacheMessageEntryWeight key.parameter
+      (targetCertificateForecast key reuse budget signatures required state) state.1 input := by
+  obtain ⟨output, houtput, hmessage, hadmissible, hcovered⟩ := hcertificate
+  simp only [cacheMessageEntryWeight, houtput, hmessage, hadmissible, and_self, if_true]
+  exact one_le_targetCertificateForecast_of_covered key reuse budget signatures required state input _ hcovered
+
+private theorem empty_targetShapeValid (required : Finset FtsTree) : TargetShapeValid ∅ required := by
+  constructor <;> simp
+
+theorem targetCreationPrice_budget_mono (key : SecretKey) (reuse : ENNReal) (signatures : Nat)
+    (required : Finset FtsTree) (state : CoverLogState) {smaller larger : Nat} (hbudget : smaller ≤ larger) :
+    targetCreationPrice key reuse smaller signatures required state ≤
+      targetCreationPrice key reuse larger signatures required state := by
+  apply mul_le_mul' ?_ le_rfl
+  apply mul_le_mul' le_rfl
+  exact targetShapeEnvelope_queries_mono _ _ _ _ _ hbudget ∅ required (empty_targetShapeValid required)
+
+theorem targetCreationPrice_signatures_mono (key : SecretKey) (reuse : ENNReal) (budget : Nat)
+    (required : Finset FtsTree) (state : CoverLogState) {smaller larger : Nat} (hsignatures : smaller ≤ larger) :
+    targetCreationPrice key reuse budget smaller required state ≤
+      targetCreationPrice key reuse budget larger required state := by
+  apply mul_le_mul' ?_ le_rfl
+  apply mul_le_mul' le_rfl
+  exact Function.monotone_iterate_of_id_le
+    (show ∀ f : TargetShapeVector, f ≤ targetShapeSigning (Fintype.card Index : ENNReal)⁻¹ reuse f from
+      fun _ _ _ => (le_self_add).trans le_self_add)
+    hsignatures _ ∅ required
+
+theorem bankedTargetEnvelope_budget_mono (key : SecretKey) (reuse : ENNReal) (signatures : Nat)
+    (required : Finset FtsTree) (state : CoverLogState) (bank : HashInput → Bool) (stopped : Bool)
+    {smaller larger : Nat} (hbudget : smaller ≤ larger) :
+    bankedTargetEnvelope key reuse smaller signatures required state bank stopped ≤
+      bankedTargetEnvelope key reuse larger signatures required state bank stopped := by
+  apply bankedCacheWeight_mono
+  intro input target
+  exact mul_le_mul' (reuseTargetEnvelope_budget_mono key reuse (payloadOf input) target signatures state
+    hbudget ∅ required (empty_targetShapeValid required)) le_rfl
+
+theorem newTargetCertificateForecast_eq (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat)
+    (required : Finset FtsTree) (before : QueryCache HashSpec) (after : CoverLogState) :
+    cacheMessageWeight key.parameter (fun input target => if before input = none then
+      targetCertificateForecast key reuse budget signatures required after input target else 0) after.1 =
+      reuseNewTargetEnvelope key reuse budget signatures before after ∅ required * targetCertificateScale required := by
+  unfold reuseNewTargetEnvelope newTargetEnvelopeCharge
+  rw [← cacheMessageWeight_mul_right]
+  apply congrArg (fun weight => cacheMessageWeight key.parameter weight after.1)
+  funext input target
+  by_cases hfresh : before input = none
+  · simp only [hfresh, if_true, targetCertificateForecast]
+    rfl
+  · simp only [hfresh, if_false, zero_mul]
+
+theorem expected_logTraced_world_bankedTarget_le (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat)
+    (required : Finset FtsTree) (state : CoverLogState) (bank : HashInput → Bool) (input : OracleWorld.Domain)
+    (stopped : (OracleWorld + SigningSpec).Range (.inl input) × CoverLogState → Bool)
+    (hsigned : SigningDigestsCached key.parameter state.1 key.root state.2) :
+    (∑' result, Pr[= result | (logTracedMappedAdversaryImpl key (.inl input)).run state] *
+      bankedTargetEnvelope key reuse budget signatures required result.2
+        (completedTargetBank key required result.2 bank) (stopped result)) ≤
+      bankedTargetEnvelope key reuse (budget + signingExecutionHashCost (.inl input)) signatures required state bank false +
+        (freshWorldTargetHashCost key.parameter state.1 input : ENNReal) *
+          ((((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ * (Fintype.card Index : ENNReal)⁻¹) *
+            reuseRawEnvelope key reuse budget signatures state ∅ required) * targetCertificateScale required := by
+  apply expected_bankedCacheWeight_step_le
+  · intro result hr
+    exact logTracedMappedAdversaryImpl_cache_le key (.inl input) state result hr
+  · intro result _ query hcertificate
+    exact one_le_targetCertificateEntry_of_certificate key reuse budget signatures required result.2 query
+      (of_decide_eq_true hcertificate)
+  · intro query target
+    simp only [targetCertificateForecast, ← mul_assoc, ENNReal.tsum_mul_right]
+    exact mul_le_mul' (expected_logTraced_world_reuseTarget_le key reuse budget (payloadOf query) target
+      signatures state input hsigned ∅ required (empty_targetShapeValid required)) le_rfl
+  · have h := expected_logTraced_world_reuseNewTarget_le key reuse budget signatures state input hsigned
+      ∅ required (empty_targetShapeValid required)
+    simpa only [newTargetCertificateForecast_eq, ← mul_assoc, ENNReal.tsum_mul_right] using
+      mul_le_mul' h (le_refl (targetCertificateScale required))
+
+theorem expected_logTraced_sign_bankedTarget_le (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat)
+    (required : Finset FtsTree) (state : CoverLogState) (bank : HashInput → Bool) (message : Message)
+    (stopped : (OracleWorld + SigningSpec).Range (.inr message) × CoverLogState → Bool)
+    (hsigned : SigningDigestsCached key.parameter state.1 key.root state.2)
+    (hreuse : exactDigestReuseWeight key message state.1 ≤ reuse) :
+    (∑' result, Pr[= result | (logTracedMappedAdversaryImpl key (.inr message)).run state] *
+      bankedTargetEnvelope key reuse budget signatures required result.2
+        (completedTargetBank key required result.2 bank) (stopped result)) ≤
+      bankedTargetEnvelope key reuse budget (signatures + 1) required state bank false +
+        freshDigestSelectionProbability key message state.1 *
+          ((Fintype.card Index : ENNReal)⁻¹ * reuseRawEnvelope key reuse budget signatures state ∅ required) *
+            targetCertificateScale required := by
+  apply expected_bankedCacheWeight_step_le
+  · intro result hr
+    exact logTracedMappedAdversaryImpl_cache_le key (.inr message) state result hr
+  · intro result _ query hcertificate
+    exact one_le_targetCertificateEntry_of_certificate key reuse budget signatures required result.2 query
+      (of_decide_eq_true hcertificate)
+  · intro query target
+    simp only [targetCertificateForecast, ← mul_assoc, ENNReal.tsum_mul_right]
+    exact mul_le_mul' (expected_logTraced_sign_reuseTarget_le key reuse budget (payloadOf query) target
+      signatures state hsigned message hreuse ∅ required (empty_targetShapeValid required)) le_rfl
+  · have h := expected_logTraced_sign_reuseNewTarget_le_mass_mul key reuse budget signatures state hsigned message
+      ∅ required (empty_targetShapeValid required)
+    simpa only [newTargetCertificateForecast_eq, ← mul_assoc, ENNReal.tsum_mul_right] using
+      mul_le_mul' h (le_refl (targetCertificateScale required))
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/BoundaryCertificateCache.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/BoundaryCertificateCache.lean
new file mode 100644
index 000000000..0d85257b6
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/BoundaryCertificateCache.lean
@@ -0,0 +1,125 @@
+import SphincsSecurity.Proof.Fts.OriginalCertificateBound
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+open FtsProbeSimulation (messageAnswers)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def hashRowsCache : List (HashInput × HashOutput) → QueryCache HashSpec
+  | [] => ∅
+  | row :: rows => (hashRowsCache rows).cacheQuery row.1 row.2
+
+theorem hashRowsCache_le (rows : List (HashInput × HashOutput)) (cache : QueryCache HashSpec)
+    (hrows : ∀ row ∈ rows, cache row.1 = some row.2) : hashRowsCache rows ≤ cache := by
+  induction rows with
+  | nil => exact bot_le
+  | cons row rows ih =>
+      intro input output houtput
+      by_cases heq : input = row.1
+      · subst input
+        simp only [hashRowsCache, QueryCache.cacheQuery_self, Option.some.injEq] at houtput
+        exact (hrows row (List.mem_cons_self ..)).trans (congrArg some houtput)
+      · apply ih (fun entry hentry => hrows entry (List.mem_cons_of_mem _ hentry))
+        simpa only [hashRowsCache, QueryCache.cacheQuery_of_ne _ _ heq] using houtput
+
+theorem hashRowsCache_lookup (rows : List (HashInput × HashOutput)) (f : QueryImpl HashSpec Id)
+    (hrows : ∀ row ∈ rows, row.2 = f row.1) (input : HashInput) (hinput : (input, f input) ∈ rows) :
+    hashRowsCache rows input = some (f input) := by
+  induction rows with
+  | nil => cases hinput
+  | cons row rows ih =>
+      by_cases heq : input = row.1
+      · rw [heq, hashRowsCache, QueryCache.cacheQuery_self, hrows row (List.mem_cons_self ..)]
+      · rw [hashRowsCache, QueryCache.cacheQuery_of_ne _ _ heq]
+        apply ih (fun entry hentry => hrows entry (List.mem_cons_of_mem _ hentry))
+        rcases List.mem_cons.mp hinput with hhead | htail
+        · exact False.elim (heq (congrArg Prod.fst hhead))
+        · exact htail
+
+private theorem romImpl_hash_cached (input : HashInput) (cache : QueryCache HashSpec)
+    (result : HashOutput × QueryCache HashSpec) (hr : result ∈ support ((romImpl (.inr input)).run cache)) :
+    result.2 input = some result.1 := by
+  change result ∈ support ((randomOracle input).run cache) at hr
+  cases hc : cache input with
+  | some output =>
+      rw [randomOracle, QueryImpl.withCaching_run_some _ hc, mem_support_pure_iff] at hr
+      subst result
+      exact hc
+  | none =>
+      rw [randomOracle, QueryImpl.withCaching_run_none _ hc, support_map] at hr
+      obtain ⟨output, _, rfl⟩ := hr
+      exact QueryCache.cacheQuery_self cache input output
+
+theorem boundaryRun_message_cached {Result : Type} (parameter : PublicParameter)
+    (computation : OracleComp OracleWorld Result) (cache : QueryCache HashSpec)
+    (result : (Result × SigningBoundaryTrace) × QueryCache HashSpec)
+    (hr : result ∈ support (boundaryRun parameter computation cache)) :
+    ∀ row ∈ result.1.2.messageCalls, result.2 row.1 = some row.2 := by
+  induction computation using OracleComp.inductionOn generalizing cache result with
+  | pure value =>
+      simp only [boundaryRun, simulateQ_pure, WriterT.run_pure, StateT.run_pure, mem_support_pure_iff] at hr
+      subst result
+      intro row hrow
+      cases hrow
+  | query_bind input next ih =>
+      rw [boundaryRun_bind, boundaryRun_query, mem_support_bind_iff] at hr
+      obtain ⟨middle, hmiddle, hr⟩ := hr
+      rw [support_map] at hmiddle
+      obtain ⟨source, hsource, rfl⟩ := hmiddle
+      rw [support_map] at hr
+      obtain ⟨last, hlast, rfl⟩ := hr
+      have hcache : source.2 ≤ last.2 := by
+        apply simulateQ_romImpl_cache_le (next source.1) source.2 (last.1.1, last.2)
+        rw [← boundaryRun_forget parameter (next source.1) source.2, support_map]
+        exact ⟨last, hlast, rfl⟩
+      intro row hrow
+      rw [SigningBoundaryTrace.messageCalls_mul, List.mem_append] at hrow
+      rcases hrow with hhead | htail
+      · cases input with
+        | inl sample => cases hhead
+        | inr input =>
+            by_cases hm : FtsProbeSimulation.MessageHashInput parameter input
+            · simp only [signingBoundaryTrace, if_pos hm] at hhead
+              change row ∈ [(input, source.1)] at hhead
+              obtain rfl := List.mem_singleton.mp hhead
+              exact hcache (romImpl_hash_cached input cache source hsource)
+            · simp [signingBoundaryTrace, SigningBoundaryTrace.messageCalls, hm] at hhead
+      · exact ih source.1 source.2 last hlast row htail
+
+theorem boundaryRun_messageCache_le {Result : Type} (parameter : PublicParameter)
+    (computation : OracleComp OracleWorld Result) (cache : QueryCache HashSpec)
+    (result : (Result × SigningBoundaryTrace) × QueryCache HashSpec)
+    (hr : result ∈ support (boundaryRun parameter computation cache)) :
+    hashRowsCache result.1.2.messageCalls ≤ result.2 :=
+  hashRowsCache_le _ _ (boundaryRun_message_cached parameter computation cache result hr)
+
+theorem eligibleSigningView?_some_mono (parameter : PublicParameter) (root : Digest)
+    (before after : QueryCache HashSpec) (hcache : before ≤ after) (payload : HashInput)
+    (entry : SigningEntry) (view : FewTimeView)
+    (hview : eligibleSigningView? (messageAnswers parameter before) root payload entry = some view) :
+    eligibleSigningView? (messageAnswers parameter after) root payload entry = some view := by
+  cases hs : entry.2 with
+  | none => simp [eligibleSigningView?, hs] at hview
+  | some signature =>
+      by_cases hp : messageDigestPayload root entry.1 signature.randomness = payload
+      · simp [eligibleSigningView?, hs, hp] at hview
+      · simp only [eligibleSigningView?, observedSigningView?, hs, Option.bind_eq_bind', Option.bind_some, if_neg hp] at hview ⊢
+        cases ho : messageAnswers parameter before (messageDigestPayload root entry.1 signature.randomness) with
+        | none => simp [ho] at hview
+        | some output =>
+            have ha : messageAnswers parameter after (messageDigestPayload root entry.1 signature.randomness) = some output := hcache ho
+            simpa only [ha, ho] using hview
+
+theorem TargetCertificateAt.mono {key : SecretKey} {required : Finset FtsTree}
+    {before after : QueryCache HashSpec} {log : QueryLog SigningSpec} {input : HashInput}
+    (h : TargetCertificateAt key required (before, log) input) (hcache : before ≤ after) :
+    TargetCertificateAt key required (after, log) input := by
+  obtain ⟨output, houtput, hm, ha, hcovered⟩ := h
+  refine ⟨output, hcache houtput, hm, ha, ?_⟩
+  intro tree ht
+  obtain ⟨slot, view, hv, hi, hl⟩ := (targetTreeMatchCount_pos_iff _ _ tree).mp (hcovered tree ht)
+  exact (targetTreeMatchCount_pos_iff _ _ tree).mpr ⟨slot, view,
+    eligibleSigningView?_some_mono key.parameter key.root before after hcache (payloadOf input) (log.get slot) view hv, hi, hl⟩
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CacheIndexMultiplicity.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CacheIndexMultiplicity.lean
new file mode 100644
index 000000000..cc003ff4d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CacheIndexMultiplicity.lean
@@ -0,0 +1,21 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CacheMessageWeight
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (MessageHashInput)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def cachedIndexMultiplicity (parameter : PublicParameter) (cache : QueryCache HashSpec) (index : Index) : ENNReal :=
+  cacheMessageWeight parameter (fun _ source => if source.1 = index then 1 else 0) cache
+
+theorem cachedIndexMultiplicity_cacheQuery (parameter : PublicParameter) (cache : QueryCache HashSpec)
+    (input : HashInput) (output : HashOutput) (hfresh : cache input = none) (index : Index) :
+    cachedIndexMultiplicity parameter (cache.cacheQuery input output) index = cachedIndexMultiplicity parameter cache index +
+      (if MessageHashInput parameter input ∧ Admissible (truncateMessageDigest output) ∧ (hashOutputFewTimeView output).1 = index then 1 else 0) := by
+  rw [cachedIndexMultiplicity, cacheMessageWeight_cacheQuery parameter _ cache input output hfresh]
+  simp only [← ite_and, and_assoc]
+  rfl
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CacheMessageSignerWeight.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CacheMessageSignerWeight.lean
new file mode 100644
index 000000000..a0870224d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CacheMessageSignerWeight.lean
@@ -0,0 +1,51 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CacheMessageWeight
+
+/-! ## SignerInputWeight -/
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+def successfulSignerInputWeight (key : SecretKey) (message : Message)
+    (weight : HashInput → FewTimeView → ENNReal)
+    (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec) : ENNReal :=
+  match result.1.1, result.1.2 with
+  | some signature, some view => weight
+      (tweakableHashInput key.parameter .message (messageDigestPayload key.root message signature.randomness)) view
+  | _, _ => 0
+
+noncomputable def cachedSignerInputWeight (key : SecretKey) (message : Message) (before : QueryCache HashSpec)
+    (weight : HashInput → FewTimeView → ENNReal) (input : HashInput) : ENNReal :=
+  match before input with
+  | none => 0
+  | some output =>
+      if (∃ randomness, input = tweakableHashInput key.parameter .message (messageDigestPayload key.root message randomness)) ∧
+          Admissible (truncateMessageDigest output) then weight input (hashOutputFewTimeView output) else 0
+
+end SphincsSecurity.Concrete
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem cachedSignerInputWeight_le_cacheMessageEntryWeight (key : SecretKey) (message : Message)
+    (before : QueryCache HashSpec) (weight : HashInput → FewTimeView → ENNReal) (input : HashInput) :
+    cachedSignerInputWeight key message before weight input ≤ cacheMessageEntryWeight key.parameter weight before input := by
+  unfold cachedSignerInputWeight cacheMessageEntryWeight
+  cases before input with
+  | none => exact le_rfl
+  | some output =>
+      simp only
+      split_ifs with hsource htarget
+      · exact le_rfl
+      · obtain ⟨randomness, heq⟩ := hsource.1
+        exact (htarget ⟨⟨messageDigestPayload key.root message randomness, heq.symm⟩, hsource.2⟩).elim
+      · exact bot_le
+      · exact le_rfl
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CacheMessageWeight.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CacheMessageWeight.lean
new file mode 100644
index 000000000..4bff44d40
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CacheMessageWeight.lean
@@ -0,0 +1,158 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FewTimeUniform
+import SphincsSecurity.Proof.Fts.JointProbeMessageAnswers
+import SphincsSecurity.Proof.Fts.JointProbeMessageReserve
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (MessageHashInput messageAnswers)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def cacheMessageEntryWeight (parameter : PublicParameter)
+    (weight : HashInput → FewTimeView → ENNReal) (cache : QueryCache HashSpec) (input : HashInput) : ENNReal :=
+  match cache input with
+  | none => 0
+  | some output => if MessageHashInput parameter input ∧ Admissible (truncateMessageDigest output) then
+      weight input (hashOutputFewTimeView output) else 0
+
+noncomputable def cacheMessageWeight (parameter : PublicParameter)
+    (weight : HashInput → FewTimeView → ENNReal) (cache : QueryCache HashSpec) : ENNReal :=
+  ∑' input, cacheMessageEntryWeight parameter weight cache input
+
+theorem cacheMessageWeight_messageAnswers_congr (parameter : PublicParameter)
+    (before after : QueryCache HashSpec) (hanswers : messageAnswers parameter before = messageAnswers parameter after)
+    (weight : HashInput → FewTimeView → ENNReal) :
+    cacheMessageWeight parameter weight before = cacheMessageWeight parameter weight after := by
+  apply tsum_congr
+  intro input
+  by_cases hm : MessageHashInput parameter input
+  · obtain ⟨payload, rfl⟩ := hm
+    have heq := congrFun hanswers payload
+    change before (tweakableHashInput parameter .message payload) = after (tweakableHashInput parameter .message payload) at heq
+    simp only [cacheMessageEntryWeight, heq]
+  · unfold cacheMessageEntryWeight
+    cases before input <;> cases after input <;> simp [hm]
+
+theorem cacheMessageWeight_mono (parameter : PublicParameter)
+    (first second : HashInput → FewTimeView → ENNReal) (cache : QueryCache HashSpec)
+    (h : ∀ input target, first input target ≤ second input target) :
+    cacheMessageWeight parameter first cache ≤ cacheMessageWeight parameter second cache := by
+  apply ENNReal.tsum_le_tsum
+  intro input
+  unfold cacheMessageEntryWeight
+  cases cache input with
+  | none => exact le_rfl
+  | some output => simp only; split_ifs; exact h input _; exact le_rfl
+
+theorem cacheMessageWeight_add (parameter : PublicParameter)
+    (first second : HashInput → FewTimeView → ENNReal) (cache : QueryCache HashSpec) :
+    cacheMessageWeight parameter (fun input target => first input target + second input target) cache =
+      cacheMessageWeight parameter first cache + cacheMessageWeight parameter second cache := by
+  rw [cacheMessageWeight, cacheMessageWeight, cacheMessageWeight, ← ENNReal.tsum_add]
+  apply tsum_congr
+  intro input
+  unfold cacheMessageEntryWeight
+  cases cache input <;> simp only
+  · exact (add_zero _).symm
+  · split_ifs <;> simp only [add_zero]
+
+theorem cacheMessageWeight_mul_right (parameter : PublicParameter)
+    (weight : HashInput → FewTimeView → ENNReal) (cache : QueryCache HashSpec) (factor : ENNReal) :
+    cacheMessageWeight parameter (fun input view => weight input view * factor) cache =
+      cacheMessageWeight parameter weight cache * factor := by
+  unfold cacheMessageWeight
+  rw [← ENNReal.tsum_mul_right]
+  apply tsum_congr
+  intro input
+  unfold cacheMessageEntryWeight
+  cases cache input with
+  | none => exact (zero_mul _).symm
+  | some output => simp only; split_ifs <;> simp only [zero_mul]
+
+theorem cacheMessageWeight_sum {α : Type} [DecidableEq α] (parameter : PublicParameter) (indices : Finset α)
+    (weight : α → HashInput → FewTimeView → ENNReal) (cache : QueryCache HashSpec) :
+    cacheMessageWeight parameter (fun input source => ∑ index ∈ indices, weight index input source) cache =
+      ∑ index ∈ indices, cacheMessageWeight parameter (weight index) cache := by
+  induction indices using Finset.induction_on with
+  | empty =>
+      simp only [Finset.sum_empty, cacheMessageWeight, cacheMessageEntryWeight]
+      apply ENNReal.tsum_eq_zero.mpr
+      intro input
+      cases cache input <;> simp
+  | @insert index indices hnot ih =>
+      simp only [Finset.sum_insert hnot, cacheMessageWeight_add, ih]
+
+theorem cacheMessageWeight_of_no_message (parameter : PublicParameter)
+    (weight : HashInput → FewTimeView → ENNReal) (cache : QueryCache HashSpec)
+    (hnone : ∀ input, MessageHashInput parameter input → cache input = none) :
+    cacheMessageWeight parameter weight cache = 0 := by
+  unfold cacheMessageWeight
+  apply ENNReal.tsum_eq_zero.mpr
+  intro input
+  unfold cacheMessageEntryWeight
+  cases hcache : cache input with
+  | none => rfl
+  | some output =>
+      simp only
+      split_ifs with hgood
+      · rw [hnone input hgood.1] at hcache
+        contradiction
+      · rfl
+
+theorem cacheMessageWeight_cacheQuery (parameter : PublicParameter)
+    (weight : HashInput → FewTimeView → ENNReal) (cache : QueryCache HashSpec)
+    (input : HashInput) (output : HashOutput) (hfresh : cache input = none) :
+    cacheMessageWeight parameter weight (cache.cacheQuery input output) =
+      cacheMessageWeight parameter weight cache +
+        (if MessageHashInput parameter input ∧ Admissible (truncateMessageDigest output) then
+          weight input (hashOutputFewTimeView output) else 0) := by
+  unfold cacheMessageWeight
+  rw [ENNReal.tsum_eq_add_tsum_ite (f := cacheMessageEntryWeight parameter weight (cache.cacheQuery input output)) input,
+    ENNReal.tsum_eq_add_tsum_ite (f := cacheMessageEntryWeight parameter weight cache) input]
+  simp only [cacheMessageEntryWeight, QueryCache.cacheQuery_self, hfresh, zero_add]
+  rw [add_comm]
+  congr 1
+  apply tsum_congr
+  intro other
+  by_cases heq : other = input
+  · simp only [heq, if_true]
+  · simp only [heq, if_false, QueryCache.cacheQuery_of_ne cache output heq]
+
+theorem expected_cacheMessageWeight {α : Type} (parameter : PublicParameter)
+    (weight : α → HashInput → FewTimeView → ENNReal) (computation : ProbComp α)
+    (cache : QueryCache HashSpec) :
+    (∑' result, Pr[= result | computation] * cacheMessageWeight parameter (weight result) cache) =
+      cacheMessageWeight parameter (fun input target => ∑' result, Pr[= result | computation] * weight result input target) cache := by
+  simp only [cacheMessageWeight, ← ENNReal.tsum_mul_left]
+  rw [ENNReal.tsum_comm]
+  apply tsum_congr
+  intro input
+  unfold cacheMessageEntryWeight
+  cases cache input with
+  | none => simp only [mul_zero, tsum_zero]
+  | some output => simp only; split_ifs <;> simp only [mul_zero, tsum_zero]
+
+theorem cacheMessageWeight_fresh_restriction (parameter : PublicParameter)
+    (weight : HashInput → FewTimeView → ENNReal) (cache : QueryCache HashSpec) :
+    cacheMessageWeight parameter (fun input target => if cache input = none then weight input target else 0) cache = 0 := by
+  apply ENNReal.tsum_eq_zero.mpr
+  intro input
+  unfold cacheMessageEntryWeight
+  cases hcache : cache input <;> simp [hcache]
+
+theorem cacheMessageWeight_of_le (parameter : PublicParameter)
+    (weight : HashInput → FewTimeView → ENNReal) (before after : QueryCache HashSpec)
+    (hcache : before ≤ after) :
+    cacheMessageWeight parameter weight after = cacheMessageWeight parameter weight before +
+      cacheMessageWeight parameter (fun input target => if before input = none then weight input target else 0) after := by
+  rw [cacheMessageWeight, cacheMessageWeight, cacheMessageWeight, ← ENNReal.tsum_add]
+  apply tsum_congr
+  intro input
+  cases hbefore : before input with
+  | none => simp only [cacheMessageEntryWeight, hbefore, if_true, zero_add]
+  | some output =>
+      simp only [cacheMessageEntryWeight, hbefore, hcache hbefore, reduceCtorEq, if_false]
+      split_ifs <;> simp only [add_zero]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CacheSize.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CacheSize.lean
new file mode 100644
index 000000000..20c6b4206
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CacheSize.lean
@@ -0,0 +1,53 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Statement
+
+/-!
+# 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
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CachedDigestRate.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CachedDigestRate.lean
new file mode 100644
index 000000000..1b93c4953
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CachedDigestRate.lean
@@ -0,0 +1,68 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.DigestSelectionMass
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+noncomputable local instance instSampleableTypeRandomness_3 : SampleableType Randomness := SampleableType.ofFintype Randomness
+
+attribute [local irreducible] signAttempt signDigestAttemptPrefix
+
+theorem cachedDigestAttemptRate_eq_count (key : SecretKey) (message : Message)
+    (cache : QueryCache HashSpec) (P : FewTimeView → Prop) :
+    cachedDigestAttemptRate key message cache P =
+      cachedMessageEntryCountWhere cache key.parameter key.root message P * ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ := by
+  let hit : Randomness → Prop := fun randomness => ∃ output,
+    cache (tweakableHashInput key.parameter .message (messageDigestPayload key.root message randomness)) = some output ∧
+      signAttemptResultOfOutput output ≠ none ∧ P (hashOutputFewTimeView output)
+  let targets : Finset Randomness := Finset.univ.filter hit
+  let fiber := cachedMessageInputSetWhere cache key.parameter key.root message P
+  let embedding : (targets : Set Randomness) ↪ fiber :=
+    ⟨fun randomness =>
+      ⟨⟨tweakableHashInput key.parameter .message (messageDigestPayload key.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⟩⟩,
+      fun left right heq => Subtype.ext <|
+        (messageDigestPayload_injective key.root <|
+          (tweakableHashInput_injective key.parameter (by trivial) (by trivial) <|
+            congrArg (fun entry : fiber => entry.1.1) heq).2).2⟩
+  have hsurjective : Function.Surjective embedding := by
+    rintro ⟨⟨input, output⟩, ⟨hcached, randomness, hinput⟩, hadmissible, hP⟩
+    change input = tweakableHashInput key.parameter .message (messageDigestPayload key.root message randomness) at hinput
+    subst input
+    have hh : hit randomness := ⟨output, hcached, hadmissible, hP⟩
+    let target : (targets : Set Randomness) := ⟨randomness, Finset.mem_filter.mpr ⟨Finset.mem_univ _, hh⟩⟩
+    refine ⟨target, Subtype.ext ?_⟩
+    have hout := Option.some.inj ((Classical.choose_spec (Finset.mem_filter.mp target.2).2).1.symm.trans hcached)
+    exact Sigma.ext (by rfl) (heq_of_eq hout)
+  have hcard : (targets.card : ENNReal) = cachedMessageEntryCountWhere cache key.parameter key.root message P := by
+    have h := Set.encard_congr (Equiv.ofBijective embedding ⟨embedding.injective, hsurjective⟩)
+    simpa only [cachedMessageEntryCountWhere, fiber, Set.encard_coe_eq_coe_finsetCard, ENat.toENNReal_coe] using
+      congrArg ENat.toENNReal h
+  rw [cachedDigestAttemptRate, probEvent_uniformSample, card_randomness, div_eq_mul_inv]
+  change (targets.card : ENNReal) * ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ = _
+  rw [hcard]
+
+noncomputable def exactDigestReuseWeight (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) : ENNReal :=
+  digestAttemptExpectation digestAttemptLimit key message cache * ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹
+
+theorem probEvent_signDigestLoop_prehit_eq_count_mul_exactWeight
+    (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) (P : FewTimeView → Prop) :
+    Pr[PrehitSelectedView cache key message P |
+      (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run cache] =
+      cachedMessageEntryCountWhere cache key.parameter key.root message P * exactDigestReuseWeight key message cache := by
+  rw [probEvent_signDigestLoop_prehit_eq_rate_mul_attempts digestAttemptLimit key message cache cache le_rfl,
+    cachedDigestAttemptRate_eq_count, exactDigestReuseWeight]
+  ring
+
+theorem freshSelection_add_count_exactWeight_add_exhaustion (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) :
+    freshDigestSelectionProbability key message cache +
+      cachedMessageEntryCountWhere cache key.parameter key.root message (fun _ => True) * exactDigestReuseWeight key message cache +
+      digestExhaustionProbability key message cache = 1 := by
+  have h := freshSelection_add_cachedAttempts_add_exhaustion key message cache
+  rw [cachedDigestAttemptRate_eq_count] at h
+  unfold exactDigestReuseWeight
+  convert h using 1; ring
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CachedDigestSelection.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CachedDigestSelection.lean
new file mode 100644
index 000000000..77841023c
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CachedDigestSelection.lean
@@ -0,0 +1,87 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.DigestAttemptExpectation
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] signAttempt signDigestAttemptPrefix
+
+private theorem probEvent_digestContinuation_prehit_eq
+    (attempts : Nat) (key : SecretKey) (message : Message)
+    (referenceCache workingCache : QueryCache HashSpec) (hreference : referenceCache ≤ workingCache)
+    (P : FewTimeView → Prop) (result : DigestAttemptResult)
+    (hr : result ∈ support (signDigestAttemptPrefix key message workingCache)) :
+    Pr[PrehitSelectedView referenceCache key message P |
+      signDigestLoopContinuation attempts key message result.1 result.2] =
+      (if FavorablePrehitAttempt referenceCache key message P result then 1 else 0) +
+        (if result.2.1 = none then Pr[PrehitSelectedView referenceCache key message P |
+          (simulateQ romImpl (signDigestLoop attempts key message)).run result.2.2] else 0) := by
+  cases hresult : result.2.1 with
+  | none =>
+      have hnot : ¬ FavorablePrehitAttempt referenceCache key message P result := by
+        rintro ⟨output, hc, ha, _⟩
+        have heq := signDigestAttemptPrefix_cached_result key message workingCache result output hr (hreference hc)
+        exact ha (heq.symm.trans hresult)
+      simp only [signDigestLoopContinuation, hresult, if_true, if_neg hnot, zero_add]
+  | some selected =>
+      obtain ⟨index, leaves⟩ := selected
+      have hiff : PrehitSelectedView referenceCache key message P
+          (some (result.1, index, leaves), result.2.2) ↔ FavorablePrehitAttempt referenceCache key message P result := by
+        constructor
+        · rintro ⟨randomness, foundIndex, foundLeaves, hfound, output, hc, ho, hP⟩
+          have hfirst := congrArg Prod.fst (Option.some.inj hfound)
+          refine ⟨output, ?_, ?_, hP⟩
+          · rw [hfirst]
+            exact hc
+          · rw [ho]
+            exact Option.some_ne_none _
+        · rintro ⟨output, hc, _, hP⟩
+          have heq := signDigestAttemptPrefix_cached_result key message workingCache result output hr (hreference hc)
+          exact ⟨result.1, index, leaves, rfl, output, hc, heq.symm.trans hresult, hP⟩
+      simp only [signDigestLoopContinuation, hresult, probEvent_pure, Option.some_ne_none, if_false, add_zero, hiff]
+
+theorem probEvent_signDigestLoop_prehit_recurrence
+    (attempts : Nat) (key : SecretKey) (message : Message)
+    (referenceCache workingCache : QueryCache HashSpec) (hreference : referenceCache ≤ workingCache)
+    (P : FewTimeView → Prop) :
+    Pr[PrehitSelectedView referenceCache key message P |
+      (simulateQ romImpl (signDigestLoop (attempts + 1) key message)).run workingCache] =
+      cachedDigestAttemptRate key message referenceCache P +
+        ∑' result, Pr[= result | signDigestAttemptPrefix key message workingCache] *
+          if result.2.1 = none then Pr[PrehitSelectedView referenceCache key message P |
+            (simulateQ romImpl (signDigestLoop attempts key message)).run result.2.2] else 0 := by
+  rw [signDigestLoop_run_succ_eq_attemptPrefix, probEvent_bind_eq_tsum,
+    ← probEvent_signDigestAttemptPrefix_favorablePrehit_eq referenceCache workingCache key message P,
+    probEvent_eq_tsum_ite, ← ENNReal.tsum_add]
+  apply tsum_congr
+  intro result
+  by_cases hr : result ∈ support (signDigestAttemptPrefix key message workingCache)
+  · rw [probEvent_digestContinuation_prehit_eq attempts key message referenceCache workingCache hreference P result hr]
+    split_ifs <;> ring
+  · simp only [probOutput_eq_zero_of_not_mem_support hr, zero_mul, ite_self, zero_add]
+
+theorem probEvent_signDigestLoop_prehit_eq_rate_mul_attempts
+    (attempts : Nat) (key : SecretKey) (message : Message)
+    (referenceCache workingCache : QueryCache HashSpec) (hreference : referenceCache ≤ workingCache)
+    (P : FewTimeView → Prop) :
+    Pr[PrehitSelectedView referenceCache key message P |
+      (simulateQ romImpl (signDigestLoop attempts key message)).run workingCache] =
+      cachedDigestAttemptRate key message referenceCache P * digestAttemptExpectation attempts key message workingCache := by
+  induction attempts generalizing workingCache with
+  | zero =>
+      simp [signDigestLoop, PrehitSelectedView, digestAttemptExpectation]
+  | succ attempts ih =>
+      rw [probEvent_signDigestLoop_prehit_recurrence attempts key message referenceCache workingCache hreference P,
+        digestAttemptExpectation, mul_add, mul_one, ← ENNReal.tsum_mul_left]
+      congr 1
+      apply tsum_congr
+      intro result
+      by_cases hr : result ∈ support (signDigestAttemptPrefix key message workingCache)
+      · by_cases hnone : result.2.1 = none
+        · rw [if_pos hnone, if_pos hnone, ih result.2.2
+            (hreference.trans (signDigestAttemptPrefix_cache_le key message workingCache result hr))]
+          ring
+        · simp only [if_neg hnone, mul_zero]
+      · rw [probOutput_eq_zero_of_not_mem_support hr, zero_mul, zero_mul, mul_zero]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CachedIndexExcessConcentration.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CachedIndexExcessConcentration.lean
new file mode 100644
index 000000000..d10fe70e7
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CachedIndexExcessConcentration.lean
@@ -0,0 +1,54 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CachedIndexHashMoments
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+
+noncomputable def cachedIndexExcessMoment (parameter : PublicParameter) (cache : QueryCache HashSpec) : ENNReal :=
+  ∑ index : Index, positiveScoreMoment (cachedIndexExcessScore parameter cache index) 2
+
+theorem cachedIndexExcessExceptional_moment_ge (parameter : PublicParameter) (cache : QueryCache HashSpec)
+    (hbad : CachedIndexExcessExceptional parameter cache) :
+    (2 ^ 160 : ENNReal) ≤ cachedIndexExcessMoment parameter cache := by
+  obtain ⟨index, hindex⟩ := hbad
+  have hpower : (2 ^ 160 : ℝ) ≤ max (cachedIndexExcessScore parameter cache index) 0 ^ 2 := by
+    calc
+      _ = (2 ^ 80 : ℝ) ^ 2 := by rw [← pow_mul]
+      _ ≤ _ := pow_le_pow_left₀ (by positivity) (hindex.le.trans (le_max_left _ _)) 2
+  have hreal := ENNReal.ofReal_le_ofReal hpower
+  rw [ENNReal.ofReal_pow (by positivity), ENNReal.ofReal_ofNat] at hreal
+  exact hreal.trans (Finset.single_le_sum (s := Finset.univ)
+    (f := fun index => positiveScoreMoment (cachedIndexExcessScore parameter cache index) 2)
+    (fun _ _ => zero_le) (Finset.mem_univ index))
+
+theorem cachedIndexExcessMoment_zero_of_no_message (parameter : PublicParameter)
+    (cache : QueryCache HashSpec)
+    (hnone : ∀ input, FtsProbeSimulation.MessageHashInput parameter input → cache input = none) :
+    cachedIndexExcessMoment parameter cache = 0 := by
+  apply Finset.sum_eq_zero
+  intro index _
+  exact positiveScoreMoment_zero_of_nonpos _
+    (cachedIndexExcessScore_nonpos_of_no_message parameter cache hnone index) 2 (by decide)
+
+theorem expected_cachedIndexExcessMoment_le (parameter : PublicParameter)
+    (cache : QueryCache HashSpec) (hfinite : Finite cache) (input : HashInput) (hfresh : cache input = none) :
+    (∑' output, Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] *
+      cachedIndexExcessMoment parameter (cache.cacheQuery input output)) ≤
+        cachedIndexExcessMoment parameter cache + (2 ^ 10 : ENNReal)⁻¹ := by
+  calc
+    _ = ∑ index : Index, ∑' output, Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] *
+        positiveScoreMoment (cachedIndexExcessScore parameter (cache.cacheQuery input output) index) 2 := by
+      simp only [cachedIndexExcessMoment, Finset.mul_sum]
+      exact Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)
+    _ ≤ ∑ index : Index, (positiveScoreMoment (cachedIndexExcessScore parameter cache index) 2 +
+        ((2 ^ 36 : Nat) : ENNReal)⁻¹) :=
+      Finset.sum_le_sum (fun index _ => expected_cachedIndexScore_second_le parameter cache hfinite input hfresh index)
+    _ = _ := by
+      rw [Finset.sum_add_distrib, Finset.sum_const, Finset.card_univ, nsmul_eq_mul]
+      congr 1
+      have hcard : Fintype.card Index = 2 ^ 26 := Fintype.card_fin _
+      rw [hcard]
+      apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp
+      norm_num [ENNReal.toReal_mul, ENNReal.toReal_inv]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CachedIndexExcessScore.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CachedIndexExcessScore.lean
new file mode 100644
index 000000000..794b97b12
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CachedIndexExcessScore.lean
@@ -0,0 +1,122 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CacheIndexMultiplicity
+
+/-! ## CacheGrowthCharge -/
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem enncard_cacheQuery_of_fresh (cache : QueryCache HashSpec) (input : HashInput)
+    (output : HashOutput) (hfresh : cache input = none) :
+    QueryCache.enncard (cache.cacheQuery input output) = QueryCache.enncard cache + 1 := by
+  have hset : (cache.cacheQuery input output).toSet = insert ⟨input, output⟩ cache.toSet := by
+    apply Set.Subset.antisymm (QueryCache.toSet_cacheQuery_subset_insert cache input output)
+    rintro pair (heq | hold)
+    · subst pair
+      exact QueryCache.cacheQuery_self _ _ _
+    · exact QueryCache.toSet_mono (QueryCache.le_cacheQuery cache hfresh) hold
+  have hnot : (⟨input, output⟩ : Sigma HashSpec.Range) ∉ cache.toSet := by
+    simp only [QueryCache.mem_toSet, hfresh, reduceCtorEq, not_false_eq_true]
+  unfold QueryCache.enncard
+  rw [hset, Set.encard_insert_of_notMem hnot]
+  simp
+
+end SphincsSecurity.Concrete
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (MessageHashInput)
+attribute [local instance] Classical.propDecidable
+
+theorem cachedIndexMultiplicity_le_enncard (parameter : PublicParameter) (cache : QueryCache HashSpec)
+    (hfinite : Finite cache) (index : Index) :
+    cachedIndexMultiplicity parameter cache index ≤ QueryCache.enncard cache := by
+  unfold cachedIndexMultiplicity cacheMessageWeight
+  rw [tsum_eq_sum (s := hfinite.toFinset) (fun input hnot => by
+    have hnone : cache input = none := by
+      by_contra h
+      exact hnot (hfinite.mem_toFinset.mpr h)
+    simp only [cacheMessageEntryWeight, hnone])]
+  calc
+    _ ≤ ∑ _input ∈ hfinite.toFinset, (1 : ENNReal) := by
+      apply Finset.sum_le_sum
+      intro input _
+      unfold cacheMessageEntryWeight
+      cases cache input <;> simp only
+      · exact zero_le
+      · split_ifs <;> norm_num
+    _ = _ := by
+      rw [Finset.sum_const, nsmul_eq_mul, mul_one,
+        ← Set.ncard_eq_toFinset_card {input | cache input ≠ none} hfinite]
+      exact hfinite.cachedInputs_ncard_toENNReal_eq_enncard
+
+theorem cachedIndexMultiplicity_ne_top (parameter : PublicParameter) (cache : QueryCache HashSpec)
+    (hfinite : Finite cache) (index : Index) : cachedIndexMultiplicity parameter cache index ≠ ⊤ := by
+  apply ne_top_of_le_ne_top _ (cachedIndexMultiplicity_le_enncard parameter cache hfinite index)
+  rw [← hfinite.cachedInputs_ncard_toENNReal_eq_enncard]
+  finiteness
+
+noncomputable def cachedIndexExcessScore (parameter : PublicParameter) (cache : QueryCache HashSpec)
+    (index : Index) : ℝ :=
+  (cachedIndexMultiplicity parameter cache index).toReal - (QueryCache.enncard cache).toReal / 2 ^ 36
+
+theorem cachedIndexExcessScore_cacheQuery (parameter : PublicParameter) (cache : QueryCache HashSpec)
+    (hfinite : Finite cache) (input : HashInput) (output : HashOutput)
+    (hfresh : cache input = none) (index : Index) :
+    cachedIndexExcessScore parameter (cache.cacheQuery input output) index =
+      cachedIndexExcessScore parameter cache index +
+        (if MessageHashInput parameter input ∧ Admissible (truncateMessageDigest output) ∧
+          (hashOutputFewTimeView output).1 = index then 1 else 0) - (2 ^ 36 : ℝ)⁻¹ := by
+  have hcount := cachedIndexMultiplicity_ne_top parameter cache hfinite index
+  have hcard : QueryCache.enncard cache ≠ ⊤ := by
+    rw [← hfinite.cachedInputs_ncard_toENNReal_eq_enncard]
+    finiteness
+  unfold cachedIndexExcessScore
+  rw [cachedIndexMultiplicity_cacheQuery parameter cache input output hfresh,
+    enncard_cacheQuery_of_fresh cache input output hfresh,
+    ENNReal.toReal_add hcard (by finiteness), ENNReal.toReal_one]
+  split_ifs <;> simp only [add_zero, ENNReal.toReal_add hcount (by finiteness), ENNReal.toReal_one] <;> ring
+
+theorem cachedIndexExcessScore_nonpos_of_no_message (parameter : PublicParameter)
+    (cache : QueryCache HashSpec) (hnone : ∀ input, MessageHashInput parameter input → cache input = none)
+    (index : Index) : cachedIndexExcessScore parameter cache index ≤ 0 := by
+  rw [cachedIndexExcessScore, cachedIndexMultiplicity, cacheMessageWeight_of_no_message parameter _ cache hnone,
+    ENNReal.toReal_zero, zero_sub]
+  exact neg_nonpos.mpr (div_nonneg ENNReal.toReal_nonneg (by positivity))
+
+def CachedIndexExcessExceptional (parameter : PublicParameter) (cache : QueryCache HashSpec) : Prop :=
+  ∃ index, (2 ^ 80 : ℝ) < cachedIndexExcessScore parameter cache index
+
+theorem cachedIndexExcessExceptional_of_bound_failure (parameter : PublicParameter)
+    (cache : QueryCache HashSpec) (hfinite : Finite cache) (spent : Nat)
+    (hcache : QueryCache.enncard cache ≤ spent) (index : Index)
+    (hbad : (spent : ENNReal) * ((2 ^ 36 : Nat) : ENNReal)⁻¹ + ((2 ^ 80 : Nat) : ENNReal) <
+      cachedIndexMultiplicity parameter cache index) : CachedIndexExcessExceptional parameter cache := by
+  have hcard : QueryCache.enncard cache ≠ ⊤ := by
+    rw [← hfinite.cachedInputs_ncard_toENNReal_eq_enncard]
+    finiteness
+  have hreal := (ENNReal.toReal_lt_toReal (by finiteness)
+    (cachedIndexMultiplicity_ne_top parameter cache hfinite index)).mpr hbad
+  have hcacheReal := (ENNReal.toReal_le_toReal hcard (by finiteness)).mpr hcache
+  rw [ENNReal.toReal_add (by finiteness) (by finiteness)] at hreal
+  norm_num [ENNReal.toReal_mul, ENNReal.toReal_inv] at hreal hcacheReal
+  refine ⟨index, ?_⟩
+  unfold cachedIndexExcessScore
+  have hscaled := div_le_div_of_nonneg_right hcacheReal (by positivity : (0 : ℝ) ≤ 2 ^ 36)
+  norm_num at hscaled ⊢
+  linarith
+
+theorem cachedIndex_bound_of_no_excess (parameter : PublicParameter) (cache : QueryCache HashSpec)
+    (hfinite : Finite cache) (spent : Nat) (hcache : QueryCache.enncard cache ≤ spent)
+    (hclean : ¬ CachedIndexExcessExceptional parameter cache) (index : Index) :
+    cachedIndexMultiplicity parameter cache index ≤
+      (spent : ENNReal) * ((2 ^ 36 : Nat) : ENNReal)⁻¹ + ((2 ^ 80 : Nat) : ENNReal) := by
+  by_contra hbad
+  exact hclean (cachedIndexExcessExceptional_of_bound_failure parameter cache hfinite spent hcache index
+    (lt_of_not_ge hbad))
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CachedIndexHashMoments.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CachedIndexHashMoments.lean
new file mode 100644
index 000000000..c8ea10ea1
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CachedIndexHashMoments.lean
@@ -0,0 +1,111 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Base.BernoulliExcessMoments
+import SphincsSecurity.Proof.Fts.CachedIndexExcessScore
+import SphincsSecurity.Proof.Fts.DigestSelectionIndex
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+
+def AdmissibleIndexOutput (index : Index) (output : HashOutput) : Prop :=
+  Admissible (truncateMessageDigest output) ∧ (hashOutputFewTimeView output).1 = index
+
+theorem probEvent_uniformHashOutput_admissible_index (index : Index) :
+    Pr[AdmissibleIndexOutput index | ($ᵗ HashOutput : ProbComp HashOutput)] =
+      ((2 ^ 36 : Nat) : ENNReal)⁻¹ := by
+  change Pr[fun output : HashOutput =>
+    Admissible (truncateMessageDigest output) ∧ (hashOutputFewTimeView output).1 = index |
+      ($ᵗ HashOutput : ProbComp HashOutput)] = _
+  have h := probEvent_uniformHashOutput_admissible_view (fun view => view.1 = index)
+  rw [probEvent_uniform_view_index] at h
+  have hcard : Fintype.card Index = 2 ^ 26 := Fintype.card_fin _
+  calc
+    _ = ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ * (Fintype.card Index : ENNReal)⁻¹ := by
+      simpa only [signAttemptResultOfOutput_ne_none_iff] using h
+    _ = _ := by
+      rw [hcard]
+      apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp
+      norm_num [ftsTreeHeight, ENNReal.toReal_mul, ENNReal.toReal_inv]
+
+theorem expected_uniformHashOutput_index_choice (index : Index) (accepted rejected : ENNReal) :
+    (∑' output, Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] *
+      (if AdmissibleIndexOutput index output then accepted else rejected)) =
+      ((2 ^ 36 : Nat) : ENNReal)⁻¹ * accepted +
+        (1 - ((2 ^ 36 : Nat) : ENNReal)⁻¹) * rejected := by
+  have hnot : Pr[fun output => ¬ AdmissibleIndexOutput index output |
+      ($ᵗ HashOutput : ProbComp HashOutput)] = 1 - ((2 ^ 36 : Nat) : ENNReal)⁻¹ := by
+    have h := probEvent_compl ($ᵗ HashOutput : ProbComp HashOutput) (AdmissibleIndexOutput index)
+    rw [probFailure_of_liftM_PMF, tsub_zero, probEvent_uniformHashOutput_admissible_index, add_comm] at h
+    exact ENNReal.eq_sub_of_add_eq' (by finiteness) h
+  have hsplit (output : HashOutput) :
+      Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] *
+          (if AdmissibleIndexOutput index output then accepted else rejected) =
+        (if AdmissibleIndexOutput index output then Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] else 0) * accepted +
+        (if ¬ AdmissibleIndexOutput index output then Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] else 0) * rejected := by
+    by_cases h : AdmissibleIndexOutput index output <;>
+      simp only [h, not_true_eq_false, not_false_eq_true, if_true, if_false, zero_mul, zero_add, add_zero]
+  simp_rw [hsplit, ENNReal.tsum_add, ENNReal.tsum_mul_right, ← probEvent_eq_tsum_ite,
+    probEvent_uniformHashOutput_admissible_index, hnot]
+
+private theorem bernoulliExcess_secondMoment_ennreal (score : ℝ) (probability : ENNReal)
+    (hprob : probability ≤ 1) :
+    probability * positiveScoreMoment (score + (1 - probability.toReal)) 2 +
+        (1 - probability) * positiveScoreMoment (score + (-probability.toReal)) 2 ≤
+      positiveScoreMoment score 2 + probability := by
+  have hp : probability ≠ ⊤ := ne_top_of_le_ne_top (by finiteness) hprob
+  apply (ENNReal.toReal_le_toReal (by unfold positiveScoreMoment; finiteness)
+    (by unfold positiveScoreMoment; finiteness)).mp
+  rw [ENNReal.toReal_add (by unfold positiveScoreMoment; finiteness) (by unfold positiveScoreMoment; finiteness),
+    ENNReal.toReal_add (positiveScoreMoment_ne_top _ _) hp]
+  simp only [ENNReal.toReal_mul, ENNReal.toReal_sub_of_le hprob (by finiteness), ENNReal.toReal_one,
+    positiveScoreMoment, ENNReal.toReal_ofReal (pow_nonneg (le_max_right _ _) _)]
+  exact bernoulliExcess_secondMoment_le score probability.toReal ENNReal.toReal_nonneg
+    ((ENNReal.toReal_mono (by finiteness) hprob).trans_eq ENNReal.toReal_one)
+
+theorem positiveScoreMoment_mono (power : Nat) {before after : ℝ} (hle : before ≤ after) :
+    positiveScoreMoment before power ≤ positiveScoreMoment after power :=
+  ENNReal.ofReal_le_ofReal (pow_le_pow_left₀ (le_max_right _ _) (max_le_max hle le_rfl) power)
+
+private theorem expected_cachedIndexScore_nonmessage_le (parameter : PublicParameter)
+    (cache : QueryCache HashSpec) (hfinite : Finite cache) (input : HashInput) (hfresh : cache input = none)
+    (hmessage : ¬ FtsProbeSimulation.MessageHashInput parameter input) (index : Index) (power : Nat) :
+    (∑' output, Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] *
+      positiveScoreMoment (cachedIndexExcessScore parameter (cache.cacheQuery input output) index) power) ≤
+        positiveScoreMoment (cachedIndexExcessScore parameter cache index) power := by
+  simp_rw [cachedIndexExcessScore_cacheQuery parameter cache hfinite input _ hfresh index,
+    hmessage, false_and, if_false, add_zero]
+  calc
+    _ ≤ ∑' output, Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] *
+        positiveScoreMoment (cachedIndexExcessScore parameter cache index) power := by
+      apply ENNReal.tsum_le_tsum
+      intro output
+      exact mul_le_mul' le_rfl (positiveScoreMoment_mono power (sub_le_self _ (by positivity)))
+    _ = _ := by rw [ENNReal.tsum_mul_right, tsum_probOutput_of_liftM_PMF, one_mul]
+
+theorem expected_cachedIndexScore_second_le (parameter : PublicParameter)
+    (cache : QueryCache HashSpec) (hfinite : Finite cache) (input : HashInput) (hfresh : cache input = none)
+    (index : Index) :
+    (∑' output, Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] *
+      positiveScoreMoment (cachedIndexExcessScore parameter (cache.cacheQuery input output) index) 2) ≤
+        positiveScoreMoment (cachedIndexExcessScore parameter cache index) 2 + ((2 ^ 36 : Nat) : ENNReal)⁻¹ := by
+  by_cases hmessage : FtsProbeSimulation.MessageHashInput parameter input
+  · simp_rw [cachedIndexExcessScore_cacheQuery parameter cache hfinite input _ hfresh index,
+      hmessage, true_and]
+    have hchoice (output : HashOutput) :
+        positiveScoreMoment (cachedIndexExcessScore parameter cache index +
+          (if Admissible (truncateMessageDigest output) ∧ (hashOutputFewTimeView output).1 = index then 1 else 0) -
+          (2 ^ 36 : ℝ)⁻¹) 2 =
+        if AdmissibleIndexOutput index output then
+          positiveScoreMoment (cachedIndexExcessScore parameter cache index + (1 - (2 ^ 36 : ℝ)⁻¹)) 2
+        else positiveScoreMoment (cachedIndexExcessScore parameter cache index + (-(2 ^ 36 : ℝ)⁻¹)) 2 := by
+      unfold AdmissibleIndexOutput
+      split_ifs <;> congr 1 <;> ring
+    simp_rw [hchoice]
+    rw [expected_uniformHashOutput_index_choice]
+    have h := bernoulliExcess_secondMoment_ennreal (cachedIndexExcessScore parameter cache index)
+      ((2 ^ 36 : Nat) : ENNReal)⁻¹ (by norm_num)
+    simpa only [ENNReal.toReal_inv, ENNReal.toReal_natCast, ENNReal.toReal_pow, ENNReal.toReal_ofNat,
+      Nat.cast_pow, Nat.cast_ofNat] using h
+  · exact (expected_cachedIndexScore_nonmessage_le parameter cache hfinite input hfresh hmessage index 2).trans le_self_add
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CachedSigningViews.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CachedSigningViews.lean
new file mode 100644
index 000000000..d6765dea7
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CachedSigningViews.lean
@@ -0,0 +1,48 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.ObservedAdaptiveCoverBound
+import SphincsSecurity.Proof.Fts.SignerAdmissibleMessage
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+open FtsProbeSimulation (messageAnswers)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem SigningDigestsCached.mono {parameter : PublicParameter} {root : Digest}
+    {before after : QueryCache HashSpec} {log : QueryLog SigningSpec}
+    (hsigned : SigningDigestsCached parameter before root log) (hcache : before ≤ after) :
+    SigningDigestsCached parameter after root log := by
+  intro entry hentry signature hresponse
+  obtain ⟨output, houtput⟩ := Option.ne_none_iff_exists'.mp (hsigned entry hentry signature hresponse)
+  exact Option.ne_none_iff_exists'.mpr ⟨output, hcache houtput⟩
+
+theorem eligibleSigningView?_cache_stable (parameter : PublicParameter) (root : Digest)
+    (before after : QueryCache HashSpec) (hcache : before ≤ after) (payload : HashInput) (entry : SigningEntry)
+    (hsigned : ∀ signature, entry.2 = some signature →
+      messageAnswers parameter before (messageDigestPayload root entry.1 signature.randomness) ≠ none) :
+    eligibleSigningView? (messageAnswers parameter after) root payload entry =
+      eligibleSigningView? (messageAnswers parameter before) root payload entry := by
+  cases hresponse : entry.2 with
+  | none => simp [eligibleSigningView?, hresponse]
+  | some signature =>
+      obtain ⟨output, houtput⟩ := Option.ne_none_iff_exists'.mp (hsigned signature hresponse)
+      have hafter : messageAnswers parameter after (messageDigestPayload root entry.1 signature.randomness) = some output := hcache houtput
+      simp [eligibleSigningView?, observedSigningView?, hresponse, houtput, hafter]
+
+theorem SigningDigestsCached.after_signing (key : SecretKey) (message : Message)
+    (before after : QueryCache HashSpec) (log : QueryLog SigningSpec)
+    (hsigned : SigningDigestsCached key.parameter before key.root log)
+    (response : Option Signature) (view : Option FewTimeView)
+    (hresult : ((response, view), after) ∈ support ((simulateQ romImpl (signWithView key message)).run before)) :
+    SigningDigestsCached key.parameter after key.root (log ++ [⟨message, response⟩]) := by
+  have hcache := simulateQ_romImpl_cache_le (signWithView key message) before ((response, view), after) hresult
+  intro entry hentry signature hresponse
+  rcases List.mem_append.mp hentry with hold | hnew
+  · exact (hsigned.mono hcache) entry hold signature hresponse
+  · obtain rfl := List.mem_singleton.mp hnew
+    have hresponse' : response = some signature := hresponse
+    rw [hresponse'] at hresult
+    obtain ⟨output, houtput, _, _⟩ := signWithView_successful_cached_output key message before after signature view hresult
+    exact Option.ne_none_iff_exists'.mpr ⟨output, houtput⟩
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CachedTargetIncrement.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CachedTargetIncrement.lean
new file mode 100644
index 000000000..7aae1b056
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CachedTargetIncrement.lean
@@ -0,0 +1,35 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.ObservedOccupancy
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (messageAnswers)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem eligibleSigningViews_fresh_eq_observed (parameter : PublicParameter) (root : Digest)
+    (before : QueryCache HashSpec) (log : QueryLog SigningSpec) (payload : HashInput)
+    (hfresh : before (tweakableHashInput parameter .message payload) = none)
+    (hsigned : SigningDigestsCached parameter before root log) :
+    eligibleSigningViews (messageAnswers parameter before) root payload log =
+      observedOptionalSigningViews (messageAnswers parameter before) root log := by
+  funext slot
+  simp only [eligibleSigningViews, observedOptionalSigningViews]
+  cases hresponse : (log.get slot).2 with
+  | none =>
+      change Option.bind (log.get slot).2 _ = Option.bind (log.get slot).2 _
+      rw [hresponse]
+      rfl
+  | some signature =>
+      have hne : messageDigestPayload root (log.get slot).1 signature.randomness ≠ payload := by
+        intro heq
+        have hcached := hsigned (log.get slot) (List.get_mem _ _) signature hresponse
+        apply hcached
+        change before (tweakableHashInput parameter .message (messageDigestPayload root (log.get slot).1 signature.randomness)) = none
+        rwa [heq]
+      unfold eligibleSigningView?
+      rw [hresponse]
+      change (if messageDigestPayload root (log.get slot).1 signature.randomness = payload then none else _) = _
+      rw [if_neg hne]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CachedTargetSubsetMatch.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CachedTargetSubsetMatch.lean
new file mode 100644
index 000000000..743b6db52
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CachedTargetSubsetMatch.lean
@@ -0,0 +1,32 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CacheMessageWeight
+import SphincsSecurity.Proof.Fts.SubsetTargetAssignment
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def cachedTargetSubsetMatch (parameter : PublicParameter) (cache : QueryCache HashSpec)
+    (targetInput : HashInput) (target : FewTimeView) (required : Finset FtsTree) : ENNReal :=
+  cacheMessageWeight parameter (fun input source =>
+    if input = targetInput then 0 else (sourceSubsetMatch target source required : ENNReal)) cache
+
+theorem cachedTargetSubsetMatch_cacheQuery (parameter : PublicParameter) (before : QueryCache HashSpec)
+    (targetInput : HashInput) (target : FewTimeView) (required : Finset FtsTree) (input : HashInput) (output : HashOutput)
+    (hfresh : before input = none) :
+    cachedTargetSubsetMatch parameter (before.cacheQuery input output) targetInput target required =
+      cachedTargetSubsetMatch parameter before targetInput target required +
+        if FtsProbeSimulation.MessageHashInput parameter input ∧ Admissible (truncateMessageDigest output) then
+          if input = targetInput then 0 else (sourceSubsetMatch target (hashOutputFewTimeView output) required : ENNReal) else 0 := by
+  exact cacheMessageWeight_cacheQuery parameter _ before input output hfresh
+
+theorem cachedTargetSubsetMatch_cacheQuery_self (parameter : PublicParameter) (before : QueryCache HashSpec)
+    (targetInput : HashInput) (target : FewTimeView) (required : Finset FtsTree) (output : HashOutput)
+    (hfresh : before targetInput = none) :
+    cachedTargetSubsetMatch parameter (before.cacheQuery targetInput output) targetInput target required =
+      cachedTargetSubsetMatch parameter before targetInput target required := by
+  rw [cachedTargetSubsetMatch_cacheQuery parameter before targetInput target required targetInput output hfresh]
+  simp only [if_true, ite_self, add_zero]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CanonicalCoordinateSampling.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CanonicalCoordinateSampling.lean
new file mode 100644
index 000000000..7e3c58343
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CanonicalCoordinateSampling.lean
@@ -0,0 +1,124 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CanonicalHiddenCoordinates
+import SphincsSecurity.Proof.Base.UniformTableSplit
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+attribute [local irreducible] instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+abbrev CanonicalCoordinateLabels := CanonicalCoordinate → Digest
+abbrev CanonicalGraphHighHalves := Position → Digest
+abbrev CanonicalSecretGraph :=
+  (Layer → TreeIndex → LeafIndex → ChainIndex → Digest) ×
+    (Index → FtsTree → FtsLeaf → Digest) × CanonicalGraphLabels
+
+def coordinateOtsSecrets (labels : CanonicalCoordinateLabels) : Layer → TreeIndex → LeafIndex → ChainIndex → Digest :=
+  fun lay tree leaf chain => labels (.otsStart lay tree leaf chain)
+
+def coordinateFtsSecrets (labels : CanonicalCoordinateLabels) : Index → FtsTree → FtsLeaf → Digest :=
+  fun index tree leaf => labels (.ftsStart index tree leaf)
+
+noncomputable def digestHashHalves : HashOutput ≃ Digest × Digest :=
+  splitHashOutputEquiv digestBits (by decide)
+
+def canonicalGraphHighHalves (graph : CanonicalGraphLabels) : CanonicalGraphHighHalves :=
+  fun position => (splitHashOutput digestBits (graph position)).2
+
+noncomputable def coordinateGraphLabels (labels : CanonicalCoordinateLabels)
+    (high : CanonicalGraphHighHalves) : CanonicalGraphLabels :=
+  fun position => digestHashHalves.symm (labels (.graph position), high position)
+
+theorem coordinateGraphLabels_low (labels : CanonicalCoordinateLabels)
+    (high : CanonicalGraphHighHalves) (position : Position) :
+    truncateHash (coordinateGraphLabels labels high position) = labels (.graph position) := by
+  exact congrArg Prod.fst (digestHashHalves.apply_symm_apply (labels (.graph position), high position))
+
+theorem coordinateGraphLabels_high (labels : CanonicalCoordinateLabels)
+    (high : CanonicalGraphHighHalves) :
+    canonicalGraphHighHalves (coordinateGraphLabels labels high) = high := by
+  funext position
+  exact congrArg Prod.snd (digestHashHalves.apply_symm_apply (labels (.graph position), high position))
+
+theorem coordinateGraphLabels_value (labels : CanonicalCoordinateLabels)
+    (high : CanonicalGraphHighHalves) :
+    CanonicalCoordinate.value (coordinateOtsSecrets labels) (coordinateFtsSecrets labels)
+      (coordinateGraphLabels labels high) = labels := by
+  funext coordinate
+  cases coordinate <;> simp only [CanonicalCoordinate.value, coordinateOtsSecrets, coordinateFtsSecrets,
+    coordinateGraphLabels_low]
+
+noncomputable def canonicalCoordinateEquiv :
+    CanonicalSecretGraph ≃ CanonicalCoordinateLabels × CanonicalGraphHighHalves where
+  toFun data := (CanonicalCoordinate.value data.1 data.2.1 data.2.2, canonicalGraphHighHalves data.2.2)
+  invFun data := (coordinateOtsSecrets data.1, coordinateFtsSecrets data.1, coordinateGraphLabels data.1 data.2)
+  left_inv data := by
+    rcases data with ⟨ots, fts, graph⟩
+    apply Prod.ext
+    · rfl
+    · apply Prod.ext
+      · rfl
+      · funext position
+        exact digestHashHalves.symm_apply_apply (graph position)
+  right_inv data := by
+    apply Prod.ext
+    · exact coordinateGraphLabels_value data.1 data.2
+    · exact coordinateGraphLabels_high data.1 data.2
+
+theorem uniform_canonicalCoordinateEquiv :
+    (PMF.uniformOfFintype CanonicalSecretGraph).map canonicalCoordinateEquiv =
+      (PMF.uniformOfFintype CanonicalCoordinateLabels).bind (fun labels =>
+        (PMF.uniformOfFintype CanonicalGraphHighHalves).map (fun high => (labels, high))) := by
+  rw [PMF.uniformOfFintype_map_of_bijective canonicalCoordinateEquiv canonicalCoordinateEquiv.bijective]
+  exact UniformTableSplit.uniform_product
+
+noncomputable local instance coordinateSamplingOts :
+    SampleableType (Layer → TreeIndex → LeafIndex → ChainIndex → Digest) := otsSecretsSampleableType
+
+noncomputable local instance coordinateSamplingFts :
+    SampleableType (Index → FtsTree → FtsLeaf → Digest) := ftsSecretsSampleableType
+
+attribute [local semireducible] sampleOtsSecrets sampleFtsSecrets
+
+theorem evalDist_sampleSecretGraph :
+    (do
+      let ots ← 𝒟[sampleOtsSecrets]
+      let fts ← 𝒟[sampleFtsSecrets]
+      let graph ← 𝒟[PMF.uniformOfFintype CanonicalGraphLabels]
+      pure (ots, fts, graph) : SPMF CanonicalSecretGraph) =
+        𝒟[PMF.uniformOfFintype CanonicalSecretGraph] := by
+  rw [UniformTableSplit.uniform_product]
+  simp only [← PMF.monad_bind_eq_bind, ← PMF.monad_map_eq_map,
+    evalDist_bind, evalDist_pure, map_eq_bind_pure_comp, Function.comp_def]
+  rw [show 𝒟[sampleOtsSecrets] = 𝒟[PMF.uniformOfFintype (Layer → TreeIndex → LeafIndex → ChainIndex → Digest)]
+      from evalDist_uniformSample _]
+  apply congrArg (𝒟[PMF.uniformOfFintype (Layer → TreeIndex → LeafIndex → ChainIndex → Digest)] >>= ·)
+  funext ots
+  rw [UniformTableSplit.uniform_product]
+  simp only [← PMF.monad_bind_eq_bind, ← PMF.monad_map_eq_map,
+    evalDist_bind, evalDist_pure, map_eq_bind_pure_comp, Function.comp_def, bind_assoc, pure_bind]
+  rw [show 𝒟[sampleFtsSecrets] = 𝒟[PMF.uniformOfFintype (Index → FtsTree → FtsLeaf → Digest)]
+      from evalDist_uniformSample _]
+
+theorem sampleSecretGraph_bind_coordinates {Result : Type}
+    (next : (Layer → TreeIndex → LeafIndex → ChainIndex → Digest) →
+      (Index → FtsTree → FtsLeaf → Digest) → CanonicalGraphLabels → SPMF Result) :
+    (𝒟[sampleOtsSecrets] >>= fun ots => 𝒟[sampleFtsSecrets] >>= fun fts =>
+      𝒟[PMF.uniformOfFintype CanonicalGraphLabels] >>= next ots fts) =
+        (𝒟[PMF.uniformOfFintype CanonicalCoordinateLabels] >>= fun labels =>
+          𝒟[PMF.uniformOfFintype CanonicalGraphHighHalves] >>= fun high =>
+            next (coordinateOtsSecrets labels) (coordinateFtsSecrets labels) (coordinateGraphLabels labels high)) := by
+  have h := congrArg (fun law : PMF (CanonicalCoordinateLabels × CanonicalGraphHighHalves) =>
+    𝒟[law] >>= fun data => next (coordinateOtsSecrets data.1) (coordinateFtsSecrets data.1)
+      (coordinateGraphLabels data.1 data.2)) uniform_canonicalCoordinateEquiv
+  simp only [← PMF.monad_bind_eq_bind, ← PMF.monad_map_eq_map, evalDist_bind, evalDist_map] at h
+  rw [← evalDist_sampleSecretGraph] at h
+  simp only [map_eq_bind_pure_comp, Function.comp_def, bind_assoc, pure_bind] at h
+  change (𝒟[sampleOtsSecrets] >>= fun ots => 𝒟[sampleFtsSecrets] >>= fun fts =>
+    𝒟[PMF.uniformOfFintype CanonicalGraphLabels] >>= fun graph =>
+      next (canonicalCoordinateEquiv.symm (canonicalCoordinateEquiv (ots, fts, graph))).1
+        (canonicalCoordinateEquiv.symm (canonicalCoordinateEquiv (ots, fts, graph))).2.1
+        (canonicalCoordinateEquiv.symm (canonicalCoordinateEquiv (ots, fts, graph))).2.2) = _ at h
+  simpa only [Equiv.symm_apply_apply] using h
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CanonicalHiddenCoordinates.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CanonicalHiddenCoordinates.lean
new file mode 100644
index 000000000..a2952e27d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CanonicalHiddenCoordinates.lean
@@ -0,0 +1,131 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.CanonicalGraph
+import SphincsSecurity.Proof.Hypertree.FrontierSignerErasure
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+inductive CanonicalCoordinate where
+  | otsStart (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (chain : ChainIndex)
+  | ftsStart (index : Index) (tree : FtsTree) (leaf : FtsLeaf)
+  | graph (position : Position)
+  deriving DecidableEq, Fintype
+
+namespace CanonicalCoordinate
+
+def value (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (labels : CanonicalGraphLabels) : CanonicalCoordinate → Digest
+  | .otsStart lay tree leaf chain => otsSecret lay tree leaf chain
+  | .ftsStart index tree leaf => ftsSecret index tree leaf
+  | .graph position => truncateHash (labels position)
+
+def slots : Position → List CanonicalCoordinate
+  | .chain lay tree leaf chain step =>
+      if step.val = 0 then [.otsStart lay tree leaf chain]
+      else (Position.chain lay tree leaf chain step).children.map .graph
+  | .ftsLeaf index tree leaf => [.ftsStart index tree leaf]
+  | position => position.children.map .graph
+
+def Hidden (words : OtsReferenceWords) (disclosed : Index → FtsTree → FtsLeaf → Prop) : CanonicalCoordinate → Prop
+  | .otsStart lay tree leaf chain => 0 < (words lay tree leaf chain).val
+  | .ftsStart index tree leaf => ¬disclosed index tree leaf
+  | .graph (.chain lay tree leaf chain step) => step.val + 1 < (words lay tree leaf chain).val
+  | .graph _ => False
+
+def chainChild (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (chain : ChainIndex)
+    (step : ChainStep) : CanonicalCoordinate :=
+  if step.val = 0 then .otsStart lay tree leaf chain
+  else .graph (.chain lay tree leaf chain ⟨step.val - 1, by have := step.isLt; omega⟩)
+
+theorem slots_chain (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (chain : ChainIndex) (step : ChainStep) :
+    slots (.chain lay tree leaf chain step) = [chainChild lay tree leaf chain step] := by
+  by_cases hzero : step.val = 0
+  · simp only [slots, chainChild, if_pos hzero]
+  · have hpos : 0 < step.val := by omega
+    simp only [slots, chainChild, if_neg hzero, Position.children, dif_pos hpos, List.map_cons, List.map_nil]
+
+theorem hidden_chain_child_iff (words : OtsReferenceWords) (disclosed : Index → FtsTree → FtsLeaf → Prop)
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (chain : ChainIndex) (step : ChainStep) :
+    Hidden words disclosed (chainChild lay tree leaf chain step) ↔ step.val < (words lay tree leaf chain).val := by
+  by_cases hzero : step.val = 0
+  · simp [chainChild, Hidden, hzero]
+  · simp only [chainChild, if_neg hzero, Hidden]
+    omega
+
+theorem values_slots (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (labels : CanonicalGraphLabels) (position : Position) :
+    (slots position).map (value otsSecret ftsSecret labels) = canonicalGraphSlots otsSecret ftsSecret labels position := by
+  cases position <;> simp only [slots, canonicalGraphSlots] <;>
+    first | (split <;> simp only [List.map_cons, List.map_nil, value, List.map_map, Function.comp_def]) |
+      simp only [List.map_cons, List.map_nil, value, List.map_map, Function.comp_def]
+
+theorem slots_ne_parent (position : Position) (coordinate : CanonicalCoordinate)
+    (hcoordinate : coordinate ∈ slots position) : coordinate ≠ .graph position := by
+  have hchildren (position : Position) (coordinate : CanonicalCoordinate)
+      (hmem : coordinate ∈ position.children.map CanonicalCoordinate.graph) : coordinate ≠ .graph position := by
+    obtain ⟨child, hchild, rfl⟩ := List.mem_map.mp hmem
+    intro heq
+    have heq := CanonicalCoordinate.graph.inj heq
+    subst child
+    have hlt := Position.depth_lt_of_mem_children hchild
+    omega
+  cases position <;> simp only [slots] at hcoordinate
+  case chain lay tree leaf chain step =>
+    split at hcoordinate
+    · simp only [List.mem_singleton] at hcoordinate
+      subst coordinate
+      simp
+    · exact hchildren _ _ hcoordinate
+  case ftsLeaf index tree leaf =>
+    simp only [List.mem_singleton] at hcoordinate
+    subst coordinate
+    simp
+  all_goals exact hchildren _ _ hcoordinate
+
+theorem hidden_slot_unary (words : OtsReferenceWords) (disclosed : Index → FtsTree → FtsLeaf → Prop)
+    (position : Position) (coordinate : CanonicalCoordinate)
+    (hcoordinate : coordinate ∈ slots position) (hhidden : Hidden words disclosed coordinate) :
+    slots position = [coordinate] := by
+  cases position with
+  | chain lay tree leaf chain step =>
+      simp only [slots] at hcoordinate ⊢
+      by_cases hzero : step.val = 0
+      · simp only [if_pos hzero, List.mem_singleton] at hcoordinate ⊢
+        rw [hcoordinate]
+      · have hpos : 0 < step.val := by omega
+        simp only [if_neg hzero, Position.children, dif_pos hpos, List.map_cons, List.map_nil,
+          List.mem_singleton] at hcoordinate ⊢
+        rw [hcoordinate]
+  | ftsLeaf index tree leaf =>
+      simp only [slots, List.mem_singleton] at hcoordinate
+      subst coordinate
+      rfl
+  | leaf lay tree leaf =>
+      simp only [slots, Position.children, List.map_ofFn, List.mem_ofFn] at hcoordinate
+      obtain ⟨chain, rfl⟩ := hcoordinate
+      have hdigit := (words lay tree leaf chain).isLt
+      norm_num [Hidden, Position.lastChainStep, chainLength, winternitzBits, Function.comp_def] at hhidden
+      simp only [chainLength, winternitzBits] at hdigit
+      omega
+  | node lay tree level index =>
+      simp only [slots, Position.children] at hcoordinate
+      split_ifs at hcoordinate <;>
+        simp only [List.map_cons, List.map_nil, List.mem_cons, List.not_mem_nil, or_false] at hcoordinate
+      · rcases hcoordinate with rfl | rfl <;> exact hhidden.elim
+      · rcases hcoordinate with rfl | rfl <;> exact hhidden.elim
+  | ftsNode index tree level leaf =>
+      simp only [slots, Position.children] at hcoordinate
+      split_ifs at hcoordinate <;>
+        simp only [List.map_cons, List.map_nil, List.mem_cons, List.not_mem_nil, or_false] at hcoordinate
+      · rcases hcoordinate with rfl | rfl <;> exact hhidden.elim
+      · rcases hcoordinate with rfl | rfl <;> exact hhidden.elim
+  | ftsRoots index =>
+      simp only [slots, Position.children, List.map_ofFn, List.mem_ofFn] at hcoordinate
+      obtain ⟨tree, rfl⟩ := hcoordinate
+      exact hhidden.elim
+
+end CanonicalCoordinate
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateBankCompleteness.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateBankCompleteness.lean
new file mode 100644
index 000000000..d24e57f80
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateBankCompleteness.lean
@@ -0,0 +1,101 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CertificateCleanGame
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (retainedGameRestComputation)
+set_option backward.isDefEq.respectTransparency false
+
+def CertificateBankComplete (key : SecretKey) (required : Finset FtsTree)
+    (state : CertificateMonitorState) : Prop :=
+  ∀ input, TargetCertificateAt key required (certificateMonitorCoverState state) input →
+    state.2.bank input = true
+
+theorem certificateMonitorUpdate_bank_complete (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState)
+    (length : Nat) (record : ProposalExecutionRecord input)
+    (halive : (certificateMonitorUpdate key budget required stopAfter input state length record).stopped = false) :
+    CertificateBankComplete key required
+      (record.cache, certificateMonitorUpdate key budget required stopAfter input state length record) := by
+  by_cases hactive : CertificateMonitorActive key budget input state
+  · intro query hcertificate
+    simp only [certificateMonitorCoverState, certificateMonitorUpdate, if_pos hactive,
+      proposalRecordLogState] at hcertificate ⊢
+    exact completedTargetBank_of_certificate key required _ state.2.bank query hcertificate
+  · rw [certificateMonitorUpdate_inactive key budget required stopAfter input state length record hactive] at halive
+    contradiction
+
+theorem certificateLength_run_bank_complete {α : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (state : CertificateMonitorState)
+    (hbank : state.2.stopped = false → CertificateBankComplete key required state)
+    (result : α × CertificateMonitorState)
+    (hr : result ∈ ((simulateQ (certificateLengthImpl key budget required stopAfter) computation).run state).support)
+    (halive : result.2.2.stopped = false) : CertificateBankComplete key required result.2 := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      simp only [simulateQ_pure, StateT.run_pure, PMF.monad_pure_eq_pure, PMF.mem_support_pure_iff] at hr
+      subst result
+      exact hbank halive
+  | query_bind input next ih =>
+      rw [simulateQ_bind, simulateQ_spec_query, StateT.run_bind, PMF.monad_bind_eq_bind,
+        PMF.mem_support_bind_iff] at hr
+      obtain ⟨middle, hmiddle, hr⟩ := hr
+      obtain ⟨length, record, _, rfl⟩ :=
+        certificateLengthImpl_support key budget required stopAfter input state middle hmiddle
+      exact ih record.output _ (fun h =>
+        certificateMonitorUpdate_bank_complete key budget required stopAfter input state length record h) result hr halive
+
+theorem certificateCacheProposal_run_bank_complete {α : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (state : List Index × CertificateCacheMonitorState)
+    (hbank : state.2.2.1.stopped = false →
+      CertificateBankComplete key required (certificateCacheMonitorProject state.2))
+    (result : α × (List Index × CertificateCacheMonitorState))
+    (hr : result ∈ ((simulateQ (certificateCacheProposalImpl key budget required stopAfter) computation).run state).support)
+    (halive : result.2.2.2.1.stopped = false) :
+    CertificateBankComplete key required (certificateCacheMonitorProject result.2.2) := by
+  have hm := (PMF.mem_support_map_iff (Prod.map id Prod.snd) _ _).mpr ⟨result, hr, rfl⟩
+  rw [← PMF.monad_map_eq_map, simulateQ_certificateCacheProposalImpl_length] at hm
+  have hm' := (PMF.mem_support_map_iff (Prod.map id certificateCacheMonitorProject) _ _).mpr
+    ⟨(result.1, result.2.2), hm, rfl⟩
+  rw [← PMF.monad_map_eq_map, simulateQ_certificateCacheLengthImpl_project] at hm'
+  exact certificateLength_run_bank_complete key budget required stopAfter computation
+    (certificateCacheMonitorProject state.2) hbank _ hm' halive
+
+theorem initialCertificateMonitor_bank_complete (key : SecretKey) (spent : Nat)
+    (required : Finset FtsTree) (cache : QueryCache HashSpec) (stopped : Bool)
+    (hnone : ∀ input, FtsProbeSimulation.MessageHashInput key.parameter input → cache input = none) :
+    CertificateBankComplete key required (cache, initialCertificateMonitor spent stopped) := by
+  rintro input ⟨output, houtput, hmessage, _⟩
+  change cache input = some output at houtput
+  rw [hnone input hmessage] at houtput
+  contradiction
+
+theorem certificateCacheProposal_rest_clean_certificate (adversary : Adversary) (publicKey : PublicKey)
+    (key : SecretKey) (budget q spent : Nat) (required : Finset FtsTree) (hbudget : budget ≤ 2 ^ 127)
+    (hbound : (simulateQ (expandedAdversaryImpl key)
+      (retainedGameRestComputation adversary publicKey)).IsQueryBoundP (· matches .inr _) q)
+    (cache : QueryCache HashSpec) (hroom : spent + q ≤ budget)
+    (hcache : QueryCache.enncard cache ≤ spent)
+    (hnone : ∀ input, FtsProbeSimulation.MessageHashInput key.parameter input → cache input = none)
+    (result : CertificateCacheGameResult)
+    (hr : result ∈ ((simulateQ (certificateCacheProposalImpl key budget required proposalPrefixStop)
+      (retainedGameRestComputation adversary publicKey)).run
+        ([], cache, initialCertificateMonitor spent false, false)).support)
+    (hvalid : SigningTranscript.Valid result.1.1.2) (hclean : ¬ CertificateGameExceptional result)
+    (input : HashInput) (hcertificate : TargetCertificateAt key required (result.2.2.1, result.1.1.2) input) :
+    1 ≤ certificateBankCount result.2.2.2.1.bank := by
+  have hready := initialCertificateMonitor_ready key budget spent cache false hbudget (by omega) hcache hnone
+  have hresult := certificateCacheProposal_rest_clean adversary publicKey key budget q required hbudget hbound
+    ([], cache, initialCertificateMonitor spent false, false) hready rfl rfl hroom result hr hvalid hclean
+  have hbank := certificateCacheProposal_run_bank_complete key budget required proposalPrefixStop
+    (retainedGameRestComputation adversary publicKey) ([], cache, initialCertificateMonitor spent false, false)
+    (fun _ => initialCertificateMonitor_bank_complete key spent required cache false hnone) result hr hresult.1
+  apply one_le_certificateBankCount _ input
+  apply hbank input
+  change TargetCertificateAt key required (result.2.2.1, result.2.2.2.1.log) input
+  rwa [hresult.2.1]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateBoundaryInvariants.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateBoundaryInvariants.lean
new file mode 100644
index 000000000..1b8f243c4
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateBoundaryInvariants.lean
@@ -0,0 +1,107 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CertificateCachePersistence
+import SphincsSecurity.Proof.Fts.OriginalProposalBudget
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem boundaryRun_enncard_le {α : Type} (parameter : PublicParameter)
+    (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec)
+    (result : (α × SigningBoundaryTrace) × QueryCache HashSpec)
+    (hr : result ∈ support (boundaryRun parameter computation cache)) :
+    QueryCache.enncard result.2 ≤ QueryCache.enncard cache + result.1.2.hashCalls := by
+  induction computation using OracleComp.inductionOn generalizing cache result with
+  | pure value =>
+      simp only [boundaryRun, simulateQ_pure, WriterT.run_pure, StateT.run_pure,
+        support_pure, Set.mem_singleton_iff] at hr
+      subst result
+      simp only [SigningBoundaryTrace.hashCalls, FreeMonoid.toList_one, List.length_nil,
+        Nat.cast_zero, add_zero, le_refl]
+  | query_bind input next ih =>
+      rw [boundaryRun_bind, boundaryRun_query, mem_support_bind_iff] at hr
+      obtain ⟨middle, hmiddle, hr⟩ := hr
+      rw [support_map] at hmiddle
+      obtain ⟨source, hsource, rfl⟩ := hmiddle
+      rw [support_map] at hr
+      obtain ⟨last, hlast, rfl⟩ := hr
+      have htail := ih source.1 source.2 last hlast
+      rw [SigningBoundaryTrace.hashCalls_mul, signingBoundaryTrace_hashCalls_eq, Nat.cast_add]
+      cases input with
+      | inl sample =>
+          simpa only [Bool.false_eq_true, ↓reduceIte, Nat.cast_zero, zero_add,
+            romImpl_uniform_query_enncard_eq sample cache source hsource] using htail
+      | inr input =>
+          calc
+            _ ≤ QueryCache.enncard source.2 + last.1.2.hashCalls := htail
+            _ ≤ (QueryCache.enncard cache + 1) + last.1.2.hashCalls :=
+              add_le_add (romImpl_hash_query_enncard_le input cache source hsource) le_rfl
+            _ = _ := by simp only [↓reduceIte, Nat.cast_one, add_assoc]
+
+theorem originalProposalRecord_enncard_le (key : SecretKey)
+    (input : (OracleWorld + SigningSpec).Domain) (cache : QueryCache HashSpec)
+    (record : ProposalExecutionRecord input) (hr : record ∈ (originalProposalRecord key input cache).support) :
+    QueryCache.enncard record.cache ≤ QueryCache.enncard cache + record.trace.hashCalls :=
+  boundaryRun_enncard_le key.parameter (expandedAdversaryImpl key input) cache _
+    (originalProposalRecord_boundary_support key input cache record hr)
+
+theorem originalProposalRecord_signingDigestsCached (key : SecretKey)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CoverLogState)
+    (hsigned : SigningDigestsCached key.parameter state.1 key.root state.2)
+    (record : ProposalExecutionRecord input) (hr : record ∈ (originalProposalRecord key input state.1).support) :
+    SigningDigestsCached key.parameter record.cache key.root
+      (state.2 ++ signingLogFragment input record.output) := by
+  have hm := (PMF.mem_support_map_iff (fun record : ProposalExecutionRecord input =>
+    (record.output, record.cache)) _ _).mpr ⟨record, hr, rfl⟩
+  rw [originalProposalRecord_project, originalAdversaryPMFImpl_run, probCompLift_support] at hm
+  apply logTracedMappedAdversaryImpl_signingDigestsCached key input state hsigned
+    (record.output, record.cache, state.2 ++ signingLogFragment input record.output)
+  rw [logTracedMappedAdversaryImpl_run_map, support_map]
+  exact ⟨(record.output, record.cache), hm, rfl⟩
+
+theorem signingMacroHashCost_le_record (key : SecretKey)
+    (input : (OracleWorld + SigningSpec).Domain) (cache : QueryCache HashSpec)
+    (record : ProposalExecutionRecord input) (hr : record ∈ (originalProposalRecord key input cache).support) :
+    signingMacroHashCost input ≤ record.trace.hashCalls := by
+  cases input with
+  | inl world =>
+      rw [originalProposalRecord_world_hashCalls key world cache record hr]
+      cases world <;> exact le_rfl
+  | inr message =>
+      exact (by decide : 1024 ≤ 28504).trans (originalProposalRecord_sign_hashCalls key message cache record hr)
+
+theorem certificateMonitorUpdate_ready (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState)
+    (length : Nat) (record : ProposalExecutionRecord input)
+    (hr : record ∈ (originalProposalRecord key input state.1).support)
+    (hactive : CertificateMonitorActive key budget input state) (hbudget : budget ≤ 2 ^ 127)
+    (hcost : state.2.spent + record.trace.hashCalls ≤ budget)
+    (hclean : ¬ CertificateCacheExceptional key record.cache) :
+    CertificateMonitorReady key budget
+      (record.cache, certificateMonitorUpdate key budget required stopAfter input state length record) := by
+  have hcache := (originalProposalRecord_enncard_le key input state.1 record hr).trans
+    (add_le_add hactive.2.1.2.1.cache_le le_rfl)
+  have hcache' : QueryCache.enncard record.cache ≤ (state.2.spent + record.trace.hashCalls : Nat) := by
+    simpa only [Nat.cast_add] using hcache
+  have hsigned := originalProposalRecord_signingDigestsCached key input (state.1, state.2.log)
+    hactive.2.1.1 record hr
+  have hcap := proposalCacheBound_of_no_cache_exception key record.cache (Finite.of_enncard_le hcache')
+    (state.2.spent + record.trace.hashCalls) (hcost.trans hbudget) hcache' hclean
+  simpa only [CertificateMonitorReady, certificateMonitorUpdate, if_pos hactive, proposalRecordLogState] using
+    And.intro hsigned (And.intro hcap hcost)
+
+theorem certificateMonitorUpdate_stopped_eq (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState)
+    (length : Nat) (record : ProposalExecutionRecord input)
+    (hactive : CertificateMonitorActive key budget input state) :
+    (certificateMonitorUpdate key budget required stopAfter input state length record).stopped =
+      (stopAfter input state length record || decide (¬ CertificateMonitorReady key budget
+        (record.cache, certificateMonitorUpdate key budget required stopAfter input state length record))) := by
+  simp only [certificateMonitorUpdate, if_pos hactive, CertificateMonitorReady]
+  apply congrArg (fun flag => stopAfter input state length record || flag)
+  exact decide_eq_decide.mpr Iff.rfl
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateCacheExceptionGame.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateCacheExceptionGame.lean
new file mode 100644
index 000000000..846899633
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateCacheExceptionGame.lean
@@ -0,0 +1,36 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CertificateCacheMonitor
+import SphincsSecurity.Proof.Fts.CertificateGame
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (RetainedRestResult retainedGameRestComputation)
+set_option backward.isDefEq.respectTransparency false
+
+abbrev CertificateCacheGameResult := RetainedRestResult × (List Index × CertificateCacheMonitorState)
+
+def certificateCacheGameProject (result : CertificateCacheGameResult) : CertificateGameResult :=
+  (result.1, result.2.1, certificateCacheMonitorProject result.2.2)
+
+noncomputable def certificateCacheGame (adversary : Adversary) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : SecretKey → CertificateStopRule) (stopped : Bool) : PMF CertificateCacheGameResult := do
+  let generated ← (liftM (boundaryRun 0 scheme.keygen ∅) : PMF _)
+  let key := generated.1.1.2
+  (simulateQ (certificateCacheProposalImpl key budget required (stopAfter key))
+    (retainedGameRestComputation adversary generated.1.1.1)).run
+      ([], generated.2, initialCertificateMonitor generated.1.2.hashCalls stopped, false)
+
+theorem certificateCacheGame_project (adversary : Adversary) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : SecretKey → CertificateStopRule) (stopped : Bool) :
+    certificateCacheGameProject <$> certificateCacheGame adversary budget required stopAfter stopped =
+      certificateGame adversary budget required stopAfter stopped := by
+  rw [certificateCacheGame, map_bind]
+  change ((liftM (boundaryRun 0 scheme.keygen ∅) : PMF _) >>= fun generated =>
+    Prod.map id (Prod.map id certificateCacheMonitorProject) <$>
+      (simulateQ (certificateCacheProposalImpl generated.1.1.2 budget required (stopAfter generated.1.1.2))
+        (retainedGameRestComputation adversary generated.1.1.1)).run
+        ([], generated.2, initialCertificateMonitor generated.1.2.hashCalls stopped, false)) = _
+  simp_rw [simulateQ_certificateCacheProposalImpl_project]
+  rfl
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateCacheExceptionGrowth.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateCacheExceptionGrowth.lean
new file mode 100644
index 000000000..426f6421b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateCacheExceptionGrowth.lean
@@ -0,0 +1,66 @@
+import SphincsSecurity.Proof.Fts.CertificateCacheExceptionPotential
+import SphincsSecurity.Proof.Fts.MessageDeficitHashMoments
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] messageDeficitMoment cachedIndexExcessMoment positiveScoreMoment
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def certificateCacheExceptionWeight (key : SecretKey) (cache : QueryCache HashSpec) : ENNReal :=
+  messageDeficitMoment key.parameter key.root cache 2 / 2 ^ 186 + cachedIndexExcessMoment key.parameter cache / 2 ^ 160
+
+noncomputable def certificateCacheExceptionRate : ENNReal := 1023 / 2 ^ 186 + (2 ^ 10 : ENNReal)⁻¹ / 2 ^ 160
+
+theorem certificateCacheExceptionRate_le : certificateCacheExceptionRate ≤ (2 ^ 169 : ENNReal)⁻¹ := by
+  apply (ENNReal.toReal_le_toReal (by unfold certificateCacheExceptionRate; finiteness) (by finiteness)).mp
+  rw [certificateCacheExceptionRate, ENNReal.toReal_add (by finiteness) (by finiteness)]
+  norm_num [ENNReal.toReal_div, ENNReal.toReal_inv, ENNReal.toReal_pow]
+
+theorem messageDeficitExceptional_secondMoment_le (key : SecretKey) (cache : QueryCache HashSpec)
+    (hfinite : Finite cache) (hbad : MessageDeficitExceptional key cache) :
+    (2 : ENNReal) ^ 186 ≤ messageDeficitMoment key.parameter key.root cache 2 := by
+  obtain ⟨message, hmessage⟩ := hbad
+  have hscaled : (2 : ENNReal) ^ 93 ≤ 1024 * messageAdmissibleDeficit key message cache := by
+    calc
+      _ = 1024 * ((2 ^ 83 : Nat) : ENNReal) := by norm_num
+      _ ≤ _ := mul_le_mul' le_rfl hmessage.le
+  calc
+    _ = ((2 : ENNReal) ^ 93) ^ 2 := by rw [← pow_mul]
+    _ ≤ (1024 * messageAdmissibleDeficit key message cache) ^ 2 := pow_le_pow_left' hscaled 2
+    _ = positiveScoreMoment (messageDeficitScore key.parameter key.root message cache) 2 := by
+      rw [positiveScoreMoment_eq_pow_ofReal, messageDeficitScore_ofReal_eq key message cache hfinite]
+    _ ≤ _ := positiveScoreMoment_le_messageDeficitMoment key.parameter key.root cache 2 message
+
+theorem certificateCacheExceptionWeight_bad (key : SecretKey) (cache : QueryCache HashSpec)
+    (hfinite : Finite cache) (hbad : CertificateCacheExceptional key cache) : 1 ≤ certificateCacheExceptionWeight key cache := by
+  rcases hbad with hdeficit | hindex
+  · apply le_trans (b := messageDeficitMoment key.parameter key.root cache 2 / 2 ^ 186) _ le_self_add
+    calc
+      1 = (2 ^ 186 : ENNReal) / 2 ^ 186 := (ENNReal.div_self (by positivity) (by finiteness)).symm
+      _ ≤ _ := ENNReal.div_le_div_right (messageDeficitExceptional_secondMoment_le key cache hfinite hdeficit) _
+  · apply le_trans (b := cachedIndexExcessMoment key.parameter cache / 2 ^ 160) _ le_add_self
+    calc
+      1 = (2 ^ 160 : ENNReal) / 2 ^ 160 := (ENNReal.div_self (by positivity) (by finiteness)).symm
+      _ ≤ _ := ENNReal.div_le_div_right (cachedIndexExcessExceptional_moment_ge key.parameter cache hindex) _
+
+theorem certificateCacheExceptionWeight_initial (key : SecretKey) (cache : QueryCache HashSpec)
+    (hnone : ∀ input, FtsProbeSimulation.MessageHashInput key.parameter input → cache input = none) :
+    certificateCacheExceptionWeight key cache = 0 := by
+  have hcount := cachedMessageEntryCount_zero_of_no_inputs key.parameter key.root cache
+    (fun payload => hnone _ ⟨payload, rfl⟩)
+  rw [certificateCacheExceptionWeight, messageDeficitMoment_zero_of_no_inputs key.parameter key.root cache hcount 2 (by decide),
+    cachedIndexExcessMoment_zero_of_no_message key.parameter cache hnone, ENNReal.zero_div, ENNReal.zero_div, add_zero]
+
+theorem expected_certificateCacheExceptionWeight_le (key : SecretKey)
+    (cache : QueryCache HashSpec) (hfinite : Finite cache) (input : HashInput) (hfresh : cache input = none) :
+    (∑' output, Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] *
+      certificateCacheExceptionWeight key (cache.cacheQuery input output)) ≤
+      certificateCacheExceptionWeight key cache + certificateCacheExceptionRate := by
+  simp only [certificateCacheExceptionWeight, certificateCacheExceptionRate, div_eq_mul_inv, mul_add,
+    ← mul_assoc, ENNReal.tsum_add, ENNReal.tsum_mul_right]
+  exact (add_le_add
+    (mul_le_mul' (expected_messageDeficitMoment_second_le key.parameter key.root cache hfinite input hfresh) le_rfl)
+    (mul_le_mul' (expected_cachedIndexExcessMoment_le key.parameter cache hfinite input hfresh) le_rfl)).trans_eq (by ring)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateCacheExceptionKernels.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateCacheExceptionKernels.lean
new file mode 100644
index 000000000..c5b3890ea
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateCacheExceptionKernels.lean
@@ -0,0 +1,81 @@
+import SphincsSecurity.Proof.Fts.CertificateCacheExceptionGrowth
+import SphincsSecurity.Proof.Fts.MessageCacheProjection
+import SphincsSecurity.Proof.Reference.BoundaryMessageCost
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (messageAnswers MessageHashInput messageHashCharge)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] messageDeficitMoment cachedIndexExcessMoment positiveScoreMoment
+set_option backward.isDefEq.respectTransparency false
+
+theorem messageDeficitMoment_messageAnswers (parameter : PublicParameter) (root : Digest) (before after : QueryCache HashSpec)
+    (hanswers : messageAnswers parameter before = messageAnswers parameter after) (power : Nat) :
+    messageDeficitMoment parameter root before power = messageDeficitMoment parameter root after power := by
+  have heq := messageOnlyCache_eq_of_messageAnswers_eq parameter before after hanswers
+  have hscore (cache : QueryCache HashSpec) (message : Message) :
+      messageDeficitScore parameter root message (messageOnlyCache parameter cache) = messageDeficitScore parameter root message cache := by
+    simp only [messageDeficitScore, cachedMessageEntryCount_messageOnlyCache, cachedMessageEntryCountWhere_messageOnlyCache]
+  unfold messageDeficitMoment
+  apply Finset.sum_congr rfl
+  intro message _
+  rw [← hscore before message, ← hscore after message, heq]
+
+theorem certificateCacheExceptionWeight_messageAnswers_le (key : SecretKey) (before after : QueryCache HashSpec)
+    (hafter : Finite after) (hanswers : messageAnswers key.parameter before = messageAnswers key.parameter after)
+    (hcard : QueryCache.enncard before ≤ QueryCache.enncard after) :
+    certificateCacheExceptionWeight key after ≤ certificateCacheExceptionWeight key before := by
+  have hcardReal : (QueryCache.enncard before).toReal ≤ (QueryCache.enncard after).toReal := by
+    apply ENNReal.toReal_mono _ hcard
+    rw [← hafter.cachedInputs_ncard_toENNReal_eq_enncard]
+    finiteness
+  have hindex : cachedIndexExcessMoment key.parameter after ≤ cachedIndexExcessMoment key.parameter before := by
+    unfold cachedIndexExcessMoment
+    apply Finset.sum_le_sum
+    intro index _
+    apply positiveScoreMoment_mono
+    have hm : cachedIndexMultiplicity key.parameter before index = cachedIndexMultiplicity key.parameter after index :=
+      cacheMessageWeight_messageAnswers_congr key.parameter before after hanswers _
+    simp only [cachedIndexExcessScore, ← hm]
+    exact sub_le_sub_left (div_le_div_of_nonneg_right hcardReal (by positivity)) _
+  unfold certificateCacheExceptionWeight
+  rw [← messageDeficitMoment_messageAnswers key.parameter key.root before after hanswers]
+  exact add_le_add le_rfl (ENNReal.div_le_div_right hindex _)
+
+theorem certificateCacheExceptionWeight_nonmessage (key : SecretKey) (cache : QueryCache HashSpec) (hfinite : Finite cache)
+    (input : HashInput) (hfresh : cache input = none) (hmessage : ¬MessageHashInput key.parameter input) (output : HashOutput) :
+    certificateCacheExceptionWeight key (cache.cacheQuery input output) ≤ certificateCacheExceptionWeight key cache := by
+  apply certificateCacheExceptionWeight_messageAnswers_le key cache (cache.cacheQuery input output)
+    (finite_cacheQuery hfinite input output)
+  · funext payload
+    exact (QueryCache.cacheQuery_of_ne cache output (fun heq => hmessage ⟨payload, heq⟩)).symm
+  · rw [enncard_cacheQuery_of_fresh cache input output hfresh]
+    exact le_self_add
+
+theorem expected_certificateCacheExceptionWeight_rom (key : SecretKey) (input : OracleWorld.Domain)
+    (cache : QueryCache HashSpec) (hfinite : Finite cache) :
+    (∑' result, Pr[= result | (romImpl input).run cache] * certificateCacheExceptionWeight key result.2) ≤
+      certificateCacheExceptionWeight key cache + hashQueryCharge (fun cache hash => messageHashCharge key.parameter cache hash * certificateCacheExceptionRate) cache input := by
+  apply expected_potential_romImpl_le_charge (certificateCacheExceptionWeight key) _ ?_ input cache hfinite
+  intro current hcurrent hash hnew
+  by_cases hm : MessageHashInput key.parameter hash
+  · simpa only [messageHashCharge, if_pos hm, one_mul] using expected_certificateCacheExceptionWeight_le key current hcurrent hash hnew
+  · simp only [messageHashCharge, if_neg hm, zero_mul, add_zero]
+    calc
+      _ ≤ ∑' output, Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * certificateCacheExceptionWeight key current :=
+        ENNReal.tsum_le_tsum fun output => mul_le_mul' le_rfl (certificateCacheExceptionWeight_nonmessage key current hcurrent hash hnew hm output)
+      _ = _ := by rw [ENNReal.tsum_mul_right, tsum_probOutput_of_liftM_PMF, one_mul]
+
+theorem expected_certificateCacheExceptionWeight_boundary (key : SecretKey) (computation : OracleComp OracleWorld α)
+    (cache : QueryCache HashSpec) (hfinite : Finite cache) :
+    (∑' result, Pr[= result | boundaryRun key.parameter computation cache] * certificateCacheExceptionWeight key result.2) ≤
+      certificateCacheExceptionWeight key cache +
+        (∑' result, Pr[= result | boundaryRun key.parameter computation cache] * result.1.2.messageCalls.length) * certificateCacheExceptionRate := by
+  have h := expected_potential_simulateQ_le_queryCharge (certificateCacheExceptionWeight key)
+    (fun cache hash => messageHashCharge key.parameter cache hash * certificateCacheExceptionRate)
+    (expected_certificateCacheExceptionWeight_rom key) computation cache hfinite
+  rw [expectedQueryCharge_mul, ← expectedBoundaryMessageCalls_eq_queryCharge key.parameter computation cache,
+    ← boundaryRun_forget key.parameter computation cache, tsum_probOutput_map_mul] at h
+  exact h
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateCacheExceptionPotential.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateCacheExceptionPotential.lean
new file mode 100644
index 000000000..88cbd7ab0
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateCacheExceptionPotential.lean
@@ -0,0 +1,52 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CachedIndexExcessConcentration
+import SphincsSecurity.Proof.Base.FourthMomentExceptionBound
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+
+def CertificateCacheExceptional (key : SecretKey) (cache : QueryCache HashSpec) : Prop :=
+  MessageDeficitExceptional key cache ∨ CachedIndexExcessExceptional key.parameter cache
+
+noncomputable def certificateCacheExceptionPotential (key : SecretKey) (remaining : Nat)
+    (cache : QueryCache HashSpec) : ENNReal :=
+  fourthMomentBudget remaining (messageDeficitMoment key.parameter key.root cache 2)
+      (messageDeficitMoment key.parameter key.root cache 4) / 2 ^ 372 +
+    (cachedIndexExcessMoment key.parameter cache + (remaining : ENNReal) * (2 ^ 10 : ENNReal)⁻¹) / 2 ^ 160
+
+theorem certificateCacheExceptionPotential_bad (key : SecretKey) (remaining : Nat)
+    (cache : QueryCache HashSpec) (hfinite : Finite cache) (hbad : CertificateCacheExceptional key cache) :
+    1 ≤ certificateCacheExceptionPotential key remaining cache := by
+  rcases hbad with hdeficit | hindex
+  · apply le_trans (b := fourthMomentBudget remaining (messageDeficitMoment key.parameter key.root cache 2)
+      (messageDeficitMoment key.parameter key.root cache 4) / 2 ^ 372) _ le_self_add
+    calc
+      1 = (2 ^ 372 : ENNReal) / 2 ^ 372 := (ENNReal.div_self (by positivity) (by finiteness)).symm
+      _ ≤ _ := ENNReal.div_le_div_right
+        ((messageDeficitExceptional_fourthMoment_le key cache hfinite hdeficit).trans
+          (fourth_le_fourthMomentBudget remaining _ _)) _
+  · apply le_trans (b := (cachedIndexExcessMoment key.parameter cache +
+      (remaining : ENNReal) * (2 ^ 10 : ENNReal)⁻¹) / 2 ^ 160) _ le_add_self
+    calc
+      1 = (2 ^ 160 : ENNReal) / 2 ^ 160 := (ENNReal.div_self (by positivity) (by finiteness)).symm
+      _ ≤ _ := ENNReal.div_le_div_right
+        ((cachedIndexExcessExceptional_moment_ge key.parameter cache hindex).trans le_self_add) _
+
+theorem certificateCacheExceptionPotential_initial_le (key : SecretKey) (q : Nat) (hq : q ≤ 2 ^ 127)
+    (cache : QueryCache HashSpec)
+    (hnone : ∀ input, FtsProbeSimulation.MessageHashInput key.parameter input → cache input = none) :
+    certificateCacheExceptionPotential key q cache ≤ (q : ENNReal) / 2 ^ 223 + (q : ENNReal) / 2 ^ 170 := by
+  have hcells : ∀ payload, cache (tweakableHashInput key.parameter .message payload) = none :=
+    fun payload => hnone _ ⟨payload, rfl⟩
+  have hcounts := cachedMessageEntryCount_zero_of_no_inputs key.parameter key.root cache hcells
+  rw [certificateCacheExceptionPotential,
+    messageDeficitMoment_zero_of_no_inputs key.parameter key.root cache hcounts 2 (by decide),
+    messageDeficitMoment_zero_of_no_inputs key.parameter key.root cache hcounts 4 (by decide),
+    cachedIndexExcessMoment_zero_of_no_message key.parameter cache hnone, zero_add]
+  apply add_le_add (fourthMomentBudget_zero_le q hq)
+  apply le_of_eq
+  apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp
+  norm_num [ENNReal.toReal_div, ENNReal.toReal_mul, ENNReal.toReal_inv]
+  ring
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateCacheMonitor.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateCacheMonitor.lean
new file mode 100644
index 000000000..31d96f042
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateCacheMonitor.lean
@@ -0,0 +1,100 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CertificateCacheExceptionPotential
+import SphincsSecurity.Proof.Fts.CertificateMonitor
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+abbrev CertificateCacheMonitorState := QueryCache HashSpec × (CertificateMonitor × Bool)
+
+def certificateCacheMonitorProject (state : CertificateCacheMonitorState) : CertificateMonitorState :=
+  (state.1, state.2.1)
+
+noncomputable def certificateCacheMonitorUpdate (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateCacheMonitorState)
+    (length : Nat) (record : ProposalExecutionRecord input) : CertificateMonitor × Bool :=
+  (certificateMonitorUpdate key budget required stopAfter input (certificateCacheMonitorProject state) length record,
+    state.2.2 || decide (CertificateCacheExceptional key state.1) ||
+      decide (CertificateCacheExceptional key record.cache))
+
+noncomputable def certificateCacheLengthImpl (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule) :
+    QueryImpl (OracleWorld + SigningSpec) (StateT CertificateCacheMonitorState PMF) :=
+  originalLengthImpl key (fun state => state.2.1.spent)
+    (fun message state => certificateMonitorEnabled key budget message (certificateCacheMonitorProject state))
+    (certificateCacheMonitorUpdate key budget required stopAfter)
+
+noncomputable def certificateCacheProposalImpl (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule) :
+    QueryImpl (OracleWorld + SigningSpec) (StateT (List Index × CertificateCacheMonitorState) PMF) :=
+  originalProposalImpl key (fun state => state.2.1.spent)
+    (fun message state => certificateMonitorEnabled key budget message (certificateCacheMonitorProject state))
+    (certificateCacheMonitorUpdate key budget required stopAfter)
+
+theorem certificateCacheLengthImpl_project (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateCacheMonitorState) :
+    Prod.map id certificateCacheMonitorProject <$>
+      (certificateCacheLengthImpl key budget required stopAfter input).run state =
+        (certificateLengthImpl key budget required stopAfter input).run (certificateCacheMonitorProject state) := by
+  change PMF.map _ _ = _
+  cases input with
+  | inl world =>
+      simp only [certificateCacheLengthImpl, certificateLengthImpl, originalLengthImpl, lengthRecordImpl,
+        StateT.run_mk, originalProposalActive, Bool.false_eq_true, if_false, PMF.map_comp]
+      rfl
+  | inr message =>
+      simp only [certificateCacheLengthImpl, certificateLengthImpl, originalLengthImpl, lengthRecordImpl,
+        StateT.run_mk, originalProposalActive, certificateCacheMonitorProject]
+      split <;> simp only [PMF.map_comp] <;> rfl
+
+theorem simulateQ_certificateCacheLengthImpl_project {α : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (state : CertificateCacheMonitorState) :
+    Prod.map id certificateCacheMonitorProject <$>
+      (simulateQ (certificateCacheLengthImpl key budget required stopAfter) computation).run state =
+        (simulateQ (certificateLengthImpl key budget required stopAfter) computation).run
+          (certificateCacheMonitorProject state) :=
+  map_run_simulateQ_eq_of_query_map_eq _ _ certificateCacheMonitorProject
+    (certificateCacheLengthImpl_project key budget required stopAfter) computation state
+
+theorem simulateQ_certificateCacheProposalImpl_length {α : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (state : List Index × CertificateCacheMonitorState) :
+    Prod.map id Prod.snd <$>
+      (simulateQ (certificateCacheProposalImpl key budget required stopAfter) computation).run state =
+        (simulateQ (certificateCacheLengthImpl key budget required stopAfter) computation).run state.2 :=
+  simulateQ_originalProposalImpl_length key _ _ _ computation state
+
+theorem certificateCacheProposalImpl_project (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : List Index × CertificateCacheMonitorState) :
+    Prod.map id (Prod.map id certificateCacheMonitorProject) <$>
+      (certificateCacheProposalImpl key budget required stopAfter input).run state =
+        (certificateProposalImpl key budget required stopAfter input).run
+          (state.1, certificateCacheMonitorProject state.2) := by
+  change PMF.map _ _ = _
+  cases input with
+  | inl world =>
+      simp only [certificateCacheProposalImpl, certificateProposalImpl, originalProposalImpl, proposalRecordImpl,
+        StateT.run_mk, originalProposalActive, Bool.false_eq_true, if_false, PMF.map_comp]
+      rfl
+  | inr message =>
+      simp only [certificateCacheProposalImpl, certificateProposalImpl, originalProposalImpl, proposalRecordImpl,
+        StateT.run_mk, originalProposalActive, originalRejectedProposal, certificateCacheMonitorProject]
+      split <;> simp only [PMF.map_comp] <;> rfl
+
+theorem simulateQ_certificateCacheProposalImpl_project {α : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (state : List Index × CertificateCacheMonitorState) :
+    Prod.map id (Prod.map id certificateCacheMonitorProject) <$>
+      (simulateQ (certificateCacheProposalImpl key budget required stopAfter) computation).run state =
+        (simulateQ (certificateProposalImpl key budget required stopAfter) computation).run
+          (state.1, certificateCacheMonitorProject state.2) :=
+  map_run_simulateQ_eq_of_query_map_eq _ _ (Prod.map id certificateCacheMonitorProject)
+    (certificateCacheProposalImpl_project key budget required stopAfter) computation state
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateCachePersistence.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateCachePersistence.lean
new file mode 100644
index 000000000..4d06ca025
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateCachePersistence.lean
@@ -0,0 +1,69 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CertificateCacheMonitor
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem certificateCacheMonitorUpdate_hit (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateCacheMonitorState)
+    (length : Nat) (record : ProposalExecutionRecord input) (hhit : state.2.2 = true) :
+    (certificateCacheMonitorUpdate key budget required stopAfter input state length record).2 = true := by
+  simp only [certificateCacheMonitorUpdate, hhit, Bool.true_or]
+
+theorem certificateCacheMonitorUpdate_bad_after (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateCacheMonitorState)
+    (length : Nat) (record : ProposalExecutionRecord input)
+    (hbad : CertificateCacheExceptional key record.cache) :
+    (certificateCacheMonitorUpdate key budget required stopAfter input state length record).2 = true := by
+  simp only [certificateCacheMonitorUpdate, hbad, decide_true, Bool.or_true]
+
+theorem certificateCacheLengthImpl_support (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateCacheMonitorState)
+    (result : (OracleWorld + SigningSpec).Range input × CertificateCacheMonitorState)
+    (hr : result ∈ ((certificateCacheLengthImpl key budget required stopAfter input).run state).support) :
+    ∃ length record, record ∈ (originalProposalRecord key input state.1).support ∧
+      result = (record.output, originalProposalAdvance
+        (certificateCacheMonitorUpdate key budget required stopAfter) input state length record) := by
+  simp only [certificateCacheLengthImpl, originalLengthImpl, lengthRecordImpl, StateT.run_mk] at hr
+  split at hr
+  · rw [PMF.mem_support_map_iff] at hr
+    obtain ⟨source, hsource, rfl⟩ := hr
+    have hrecord := (PMF.mem_support_map_iff Prod.snd _ _).mpr ⟨source, hsource, rfl⟩
+    rw [recordLengthBridge_record] at hrecord
+    exact ⟨source.1, source.2, hrecord, rfl⟩
+  · rw [PMF.mem_support_map_iff] at hr
+    obtain ⟨record, hrecord, rfl⟩ := hr
+    exact ⟨0, record, hrecord, rfl⟩
+
+theorem certificateCacheLength_run_hit {α : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (state : CertificateCacheMonitorState)
+    (hhit : state.2.2 = true) (result : α × CertificateCacheMonitorState)
+    (hr : result ∈ ((simulateQ (certificateCacheLengthImpl key budget required stopAfter) computation).run state).support) :
+    result.2.2.2 = true := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      simp only [simulateQ_pure, StateT.run_pure, PMF.monad_pure_eq_pure, PMF.mem_support_pure_iff] at hr
+      subst result
+      exact hhit
+  | query_bind input next ih =>
+      rw [simulateQ_bind, simulateQ_spec_query, StateT.run_bind, PMF.monad_bind_eq_bind,
+        PMF.mem_support_bind_iff] at hr
+      obtain ⟨middle, hmiddle, hr⟩ := hr
+      obtain ⟨length, record, _, rfl⟩ :=
+        certificateCacheLengthImpl_support key budget required stopAfter input state middle hmiddle
+      exact ih record.output _ (certificateCacheMonitorUpdate_hit key budget required stopAfter input state length record hhit) result hr
+
+theorem proposalCacheBound_of_no_cache_exception (key : SecretKey) (cache : QueryCache HashSpec)
+    (hfinite : Finite cache) (spent : Nat) (hspent : spent ≤ 2 ^ 127)
+    (hcache : QueryCache.enncard cache ≤ spent) (hclean : ¬ CertificateCacheExceptional key cache) :
+    ProposalCacheBound key cache spent :=
+  ⟨hspent, hcache, fun h => hclean (Or.inl h),
+    cachedIndex_bound_of_no_excess key.parameter cache hfinite spent hcache (fun h => hclean (Or.inr h))⟩
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateCleanExecution.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateCleanExecution.lean
new file mode 100644
index 000000000..de9b62569
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateCleanExecution.lean
@@ -0,0 +1,163 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CertificateBoundaryInvariants
+import SphincsSecurity.Proof.Fts.StoppedSigningLog
+import SphincsSecurity.Proof.Fts.CertificateProposalPrefixException
+import SphincsSecurity.Proof.Fts.CertificateStoppedState
+
+/-! ## CertificateProposalPrefixPersistence -/
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+attribute [local instance] Classical.propDecidable
+
+theorem certificateLength_run_prefixOverflow {α : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (state : CertificateMonitorState)
+    (hstop : state.2.stopped = true)
+    (hbad : ProposalPrefixExceptional state.2.proposals state.2.log.length)
+    (result : α × CertificateMonitorState)
+    (hr : result ∈ ((simulateQ (certificateLengthImpl key budget required stopAfter) computation).run state).support) :
+    result.2.2.stopped = true ∧ ProposalPrefixExceptional result.2.2.proposals result.2.2.log.length := by
+  rw [certificateLength_run_stopped key budget required stopAfter computation state hstop result hr]
+  exact ⟨hstop, hbad⟩
+
+end SphincsSecurity.Concrete
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (withSigningLog withSigningLog_pure withSigningLog_query_bind)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem withSigningLog_run_length_le {σ α : Type}
+    (impl : QueryImpl (OracleWorld + SigningSpec) (StateT σ PMF))
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (log : QueryLog SigningSpec)
+    (state : σ) (result : (α × QueryLog SigningSpec) × σ)
+    (hr : result ∈ ((simulateQ impl (withSigningLog computation log)).run state).support) :
+    log.length ≤ result.1.2.length := by
+  induction computation using OracleComp.inductionOn generalizing log state result with
+  | pure value =>
+      simp only [withSigningLog_pure, simulateQ_pure, StateT.run_pure,
+        PMF.monad_pure_eq_pure, PMF.mem_support_pure_iff] at hr
+      subst result
+      exact le_rfl
+  | query_bind input next ih =>
+      rw [withSigningLog_query_bind, simulateQ_bind, simulateQ_spec_query, StateT.run_bind,
+        PMF.monad_bind_eq_bind, PMF.mem_support_bind_iff] at hr
+      obtain ⟨middle, _, hr⟩ := hr
+      have htail := ih middle.1 (log ++ signingLogFragment input middle.1) middle.2 result hr
+      rw [List.length_append] at htail
+      omega
+
+theorem certificateCacheLength_run_prefixOverflow {α : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (state : CertificateCacheMonitorState)
+    (hstop : state.2.1.stopped = true)
+    (hbad : ProposalPrefixExceptional state.2.1.proposals state.2.1.log.length)
+    (result : α × CertificateCacheMonitorState)
+    (hr : result ∈ ((simulateQ (certificateCacheLengthImpl key budget required stopAfter) computation).run state).support) :
+    ProposalPrefixExceptional result.2.2.1.proposals result.2.2.1.log.length := by
+  have hm := (PMF.mem_support_map_iff (Prod.map id certificateCacheMonitorProject) _ _).mpr ⟨result, hr, rfl⟩
+  rw [← PMF.monad_map_eq_map, simulateQ_certificateCacheLengthImpl_project] at hm
+  exact (certificateLength_run_prefixOverflow key budget required stopAfter computation
+    (certificateCacheMonitorProject state) hstop hbad _ hm).2
+
+theorem certificateCacheLength_withSigningLog_clean {α : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (hbudget : budget ≤ 2 ^ 127)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (q : Nat)
+    (hbound : (simulateQ (expandedAdversaryImpl key) computation).IsQueryBoundP (· matches .inr _) q)
+    (state : CertificateCacheMonitorState)
+    (hready : CertificateMonitorReady key budget (certificateCacheMonitorProject state))
+    (halive : state.2.1.stopped = false) (hroom : state.2.1.spent + q ≤ budget)
+    (result : (α × QueryLog SigningSpec) × CertificateCacheMonitorState)
+    (hr : result ∈ ((simulateQ (certificateCacheLengthImpl key budget required proposalPrefixStop)
+      (withSigningLog computation state.2.1.log)).run state).support)
+    (hvalid : SigningTranscript.Valid result.1.2) (hhit : result.2.2.2 = false)
+    (hprefix : ¬ ProposalPrefixExceptional result.2.2.1.proposals result.2.2.1.log.length) :
+    result.2.2.1.stopped = false ∧ result.2.2.1.log = result.1.2 ∧
+      CertificateMonitorReady key budget (certificateCacheMonitorProject result.2) := by
+  induction computation using OracleComp.inductionOn generalizing q state result with
+  | pure value =>
+      simp only [withSigningLog_pure, simulateQ_pure, StateT.run_pure,
+        PMF.monad_pure_eq_pure, PMF.mem_support_pure_iff] at hr
+      subst result
+      exact ⟨halive, rfl, hready⟩
+  | query_bind input next ih =>
+      rw [withSigningLog_query_bind, simulateQ_bind, simulateQ_spec_query, StateT.run_bind,
+        PMF.monad_bind_eq_bind, PMF.mem_support_bind_iff] at hr
+      obtain ⟨middle, hmiddle, hr⟩ := hr
+      obtain ⟨length, record, hrecord, rfl⟩ :=
+        certificateCacheLengthImpl_support key budget required proposalPrefixStop input state middle hmiddle
+      let after := originalProposalAdvance (certificateCacheMonitorUpdate key budget required proposalPrefixStop)
+        input state length record
+      have hquery := originalProposalRecord_query_bound key input next q hbound state.1 record hrecord
+      have hlogLength := withSigningLog_run_length_le
+        (certificateCacheLengthImpl key budget required proposalPrefixStop) (next record.output)
+        (state.2.1.log ++ signingLogFragment input record.output) after result hr
+      have hstepValid : ValidSigningStep state.2.1.log input := by
+        change result.1.2.length ≤ signatureLimit at hvalid
+        cases input <;> simp only [ValidSigningStep, signingLogFragment, List.length_append,
+          List.length_nil, List.length_singleton] at hlogLength ⊢ <;> omega
+      have hmin := signingMacroHashCost_le_record key input state.1 record hrecord
+      have hactive : CertificateMonitorActive key budget input (certificateCacheMonitorProject state) :=
+        ⟨halive, hready, hstepValid, by change signingMacroHashCost input ≤ budget - state.2.1.spent; omega⟩
+      have hafterHit : after.2.2 = false := by
+        apply Bool.eq_false_iff.mpr
+        intro htrue
+        have hfinal := certificateCacheLength_run_hit key budget required proposalPrefixStop
+          (withSigningLog (next record.output) (state.2.1.log ++ signingLogFragment input record.output))
+          after htrue result hr
+        rw [hhit] at hfinal
+        contradiction
+      have hafterClean : ¬ CertificateCacheExceptional key record.cache := by
+        intro hbad
+        have htrue := certificateCacheMonitorUpdate_bad_after key budget required proposalPrefixStop
+          input state length record hbad
+        change after.2.2 = true at htrue
+        rw [hafterHit] at htrue
+        contradiction
+      have hcost : state.2.1.spent + record.trace.hashCalls ≤ budget := by omega
+      have hafterReady : CertificateMonitorReady key budget (certificateCacheMonitorProject after) :=
+        certificateMonitorUpdate_ready key budget required proposalPrefixStop input
+          (certificateCacheMonitorProject state) length record hrecord hactive hbudget hcost hafterClean
+      have hstop : proposalPrefixStop input (certificateCacheMonitorProject state) length record = false := by
+        apply Bool.eq_false_iff.mpr
+        intro htrue
+        have hstopped : after.2.1.stopped = true := by
+          simp only [after, originalProposalAdvance, certificateCacheMonitorUpdate,
+            certificateMonitorUpdate, if_pos hactive, htrue, Bool.true_or]
+        have hoverflow := htrue
+        rw [proposalPrefixStop_eq_after_exception key budget required proposalPrefixStop input
+          (certificateCacheMonitorProject state) length record hactive, decide_eq_true_eq] at hoverflow
+        exact hprefix (certificateCacheLength_run_prefixOverflow key budget required proposalPrefixStop
+          (withSigningLog (next record.output) (state.2.1.log ++ signingLogFragment input record.output))
+          after hstopped hoverflow result hr)
+      have hafterAlive : after.2.1.stopped = false := by
+        change (certificateMonitorUpdate key budget required proposalPrefixStop input
+          (certificateCacheMonitorProject state) length record).stopped = false
+        rw [certificateMonitorUpdate_stopped_eq key budget required proposalPrefixStop input
+          (certificateCacheMonitorProject state) length record hactive]
+        change (proposalPrefixStop input (certificateCacheMonitorProject state) length record ||
+          decide (¬ CertificateMonitorReady key budget (certificateCacheMonitorProject after))) = false
+        simp only [hstop, hafterReady, not_true_eq_false, decide_false, Bool.false_or]
+      have hafterLog : after.2.1.log = state.2.1.log ++ signingLogFragment input record.output := by
+        change (certificateMonitorUpdate key budget required proposalPrefixStop input
+          (certificateCacheMonitorProject state) length record).log = _
+        simp only [certificateMonitorUpdate, if_pos hactive, proposalRecordLogState]
+        rfl
+      have hafterRoom : after.2.1.spent + (q - record.trace.hashCalls) ≤ budget := by
+        change (certificateMonitorUpdate key budget required proposalPrefixStop input
+          (certificateCacheMonitorProject state) length record).spent + (q - record.trace.hashCalls) ≤ budget
+        rw [certificateMonitorUpdate_spent key budget required proposalPrefixStop input
+          (certificateCacheMonitorProject state) length record hactive]
+        change state.2.1.spent + record.trace.hashCalls + (q - record.trace.hashCalls) ≤ budget
+        omega
+      apply ih record.output (q - record.trace.hashCalls) hquery.2 after hafterReady hafterAlive hafterRoom result
+      · simpa only [hafterLog] using hr
+      · exact hvalid
+      · exact hhit
+      · exact hprefix
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateCleanGame.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateCleanGame.lean
new file mode 100644
index 000000000..7770d75c9
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateCleanGame.lean
@@ -0,0 +1,83 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CertificateCleanExecution
+import SphincsSecurity.Proof.Fts.CertificateJointExceptions
+import SphincsSecurity.Proof.Residual.RetainedWorldCoverBudget
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (RetainedRestResult retainedGameRestComputation withSigningLog
+  signingTraceComputation signingTraceComputation_fst unloggedRetainedRestComputation
+  retainedGameRestComputation_eq_signingTrace arrangeRetainedTrace)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem initialCertificateMonitor_ready (key : SecretKey) (budget spent : Nat)
+    (cache : QueryCache HashSpec) (stopped : Bool)
+    (hbudget : budget ≤ 2 ^ 127) (hspent : spent ≤ budget)
+    (hcache : QueryCache.enncard cache ≤ spent)
+    (hnone : ∀ input, FtsProbeSimulation.MessageHashInput key.parameter input → cache input = none) :
+    CertificateMonitorReady key budget (cache, initialCertificateMonitor spent stopped) := by
+  have hfinite := Finite.of_enncard_le hcache
+  have hclean : ¬ CertificateCacheExceptional key cache := by
+    intro hbad
+    have hzero := certificateCacheExceptionPotential_initial_le key 0 (by omega) cache hnone
+    have hone := certificateCacheExceptionPotential_bad key 0 cache hfinite hbad
+    simp only [Nat.cast_zero, ENNReal.zero_div, add_zero] at hzero
+    exact (not_le_of_gt (by norm_num : (0 : ENNReal) < 1)) (hone.trans hzero)
+  refine ⟨?_, proposalCacheBound_of_no_cache_exception key cache hfinite spent
+    (hspent.trans hbudget) hcache hclean, hspent⟩
+  intro entry hentry
+  simp only [initialCertificateMonitor, List.not_mem_nil] at hentry
+
+theorem certificateCacheProposal_withSigningLog_clean {α : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (hbudget : budget ≤ 2 ^ 127)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (q : Nat)
+    (hbound : (simulateQ (expandedAdversaryImpl key) computation).IsQueryBoundP (· matches .inr _) q)
+    (state : List Index × CertificateCacheMonitorState)
+    (hready : CertificateMonitorReady key budget (certificateCacheMonitorProject state.2))
+    (halive : state.2.2.1.stopped = false) (hroom : state.2.2.1.spent + q ≤ budget)
+    (result : (α × QueryLog SigningSpec) × (List Index × CertificateCacheMonitorState))
+    (hr : result ∈ ((simulateQ (certificateCacheProposalImpl key budget required proposalPrefixStop)
+      (withSigningLog computation state.2.2.1.log)).run state).support)
+    (hvalid : SigningTranscript.Valid result.1.2) (hhit : result.2.2.2.2 = false)
+    (hprefix : ¬ ProposalPrefixExceptional result.2.2.2.1.proposals result.2.2.2.1.log.length) :
+    result.2.2.2.1.stopped = false ∧ result.2.2.2.1.log = result.1.2 ∧
+      CertificateMonitorReady key budget (certificateCacheMonitorProject result.2.2) := by
+  have hm := (PMF.mem_support_map_iff (Prod.map id Prod.snd) _ _).mpr ⟨result, hr, rfl⟩
+  rw [← PMF.monad_map_eq_map, simulateQ_certificateCacheProposalImpl_length] at hm
+  exact certificateCacheLength_withSigningLog_clean key budget required hbudget computation q hbound
+    state.2 hready halive hroom _ hm hvalid hhit hprefix
+
+theorem certificateCacheProposal_rest_clean (adversary : Adversary) (publicKey : PublicKey)
+    (key : SecretKey) (budget q : Nat) (required : Finset FtsTree) (hbudget : budget ≤ 2 ^ 127)
+    (hbound : (simulateQ (expandedAdversaryImpl key)
+      (retainedGameRestComputation adversary publicKey)).IsQueryBoundP (· matches .inr _) q)
+    (state : List Index × CertificateCacheMonitorState)
+    (hready : CertificateMonitorReady key budget (certificateCacheMonitorProject state.2))
+    (halive : state.2.2.1.stopped = false) (hlog : state.2.2.1.log = [])
+    (hroom : state.2.2.1.spent + q ≤ budget) (result : CertificateCacheGameResult)
+    (hr : result ∈ ((simulateQ (certificateCacheProposalImpl key budget required proposalPrefixStop)
+      (retainedGameRestComputation adversary publicKey)).run state).support)
+    (hvalid : SigningTranscript.Valid result.1.1.2) (hclean : ¬ CertificateGameExceptional result) :
+    result.2.2.2.1.stopped = false ∧ result.2.2.2.1.log = result.1.1.2 ∧
+      CertificateMonitorReady key budget (certificateCacheMonitorProject result.2.2) := by
+  rw [retainedGameRestComputation_eq_signingTrace, simulateQ_map, isQueryBoundP_map_iff] at hbound
+  have hforget : Prod.fst <$> simulateQ (expandedAdversaryImpl key)
+      (signingTraceComputation (unloggedRetainedRestComputation adversary publicKey)) =
+        simulateQ (expandedAdversaryImpl key) (unloggedRetainedRestComputation adversary publicKey) := by
+    rw [← simulateQ_map, signingTraceComputation_fst]
+  have hunlogged := (isQueryBoundP_iff_of_map_eq (p := (· matches Sum.inr _)) hforget).mp hbound
+  rw [retainedGameRestComputation_eq_signingTrace, simulateQ_map, StateT.run_map,
+    PMF.monad_map_eq_map, PMF.mem_support_map_iff] at hr
+  obtain ⟨source, hsource, rfl⟩ := hr
+  have htrace : withSigningLog (unloggedRetainedRestComputation adversary publicKey) state.2.2.1.log =
+      signingTraceComputation (unloggedRetainedRestComputation adversary publicKey) := by
+    simp only [withSigningLog, hlog, List.nil_append, Prod.mk.eta]
+    exact id_map _
+  have hresult := certificateCacheProposal_withSigningLog_clean key budget required hbudget
+    (unloggedRetainedRestComputation adversary publicKey) q hunlogged state hready halive hroom source
+    (by rwa [htrace]) hvalid (Bool.eq_false_iff.mpr (fun h => hclean (Or.inl h)))
+    (fun h => hclean (Or.inr h))
+  exact hresult
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateGame.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateGame.lean
new file mode 100644
index 000000000..0895448b8
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateGame.lean
@@ -0,0 +1,125 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CertificateMessagePayment
+import SphincsSecurity.Proof.Fts.CertificatePathBudget
+import SphincsSecurity.Proof.Ots.OtsProbeCanonicalChargeGame
+
+/-! ## OtsProbeStartErasureBound -/
+
+namespace SphincsSecurity.Concrete.OtsProbeSimulation
+
+open OracleComp OracleSpec OracleComp.ProgramLogic.Relational
+
+set_option backward.isDefEq.respectTransparency false
+set_option maxRecDepth 4000
+
+theorem simulateQ_unloggedMapped_eq_expanded (secretKey : SecretKey)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) :
+    simulateQ (unloggedMappedAdversaryImpl secretKey) computation =
+      simulateQ romImpl (simulateQ (expandedAdversaryImpl secretKey) computation) := by
+  have hhandler : unloggedMappedAdversaryImpl secretKey = romImpl ∘ₛ expandedAdversaryImpl secretKey := by
+    funext input
+    exact unloggedMappedAdversaryImpl_eq_simulateQ_expanded secretKey input
+  rw [hhandler, QueryImpl.simulateQ_compose]
+
+end SphincsSecurity.Concrete.OtsProbeSimulation
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (RetainedRestResult retainedGameRestComputation)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+private theorem simulateQ_romImpl_sampling_bind_run {α β : Type} (computation : ProbComp α)
+    (next : α → OracleComp OracleWorld β) (cache : QueryCache HashSpec) :
+    (simulateQ romImpl ((liftM computation : OracleComp OracleWorld α) >>= next)).run cache =
+      computation >>= fun value => (simulateQ romImpl (next value)).run cache := by
+  rw [simulateQ_bind, StateT.run_bind,
+    show simulateQ romImpl (liftM computation : OracleComp OracleWorld α) =
+      simulateQ (unifFwdImpl HashSpec) computation from QueryImpl.simulateQ_add_liftM_left _ _ computation,
+    unifFwdImpl.simulateQ_run, bind_map_left]
+
+theorem keygen_cache_message_none (generated : (PublicKey × SecretKey) × QueryCache HashSpec)
+    (hg : generated ∈ support ((simulateQ romImpl scheme.keygen).run ∅)) :
+    ∀ input, FtsProbeSimulation.MessageHashInput generated.1.2.parameter input → generated.2 input = none := by
+  change generated ∈ support ((simulateQ romImpl keygen).run ∅) at hg
+  rw [keygen, simulateQ_romImpl_sampling_bind_run, mem_support_bind_iff] at hg
+  obtain ⟨parameter, _, hg⟩ := hg
+  rw [simulateQ_romImpl_sampling_bind_run, mem_support_bind_iff] at hg
+  obtain ⟨otsSecret, _, hg⟩ := hg
+  rw [simulateQ_romImpl_sampling_bind_run, mem_support_bind_iff] at hg
+  obtain ⟨ftsSecret, _, hg⟩ := hg
+  rw [simulateQ_bind, StateT.run_bind, simulateQ_romImpl_liftM, mem_support_bind_iff] at hg
+  obtain ⟨root, hroot, hg⟩ := hg
+  simp only [simulateQ_pure, StateT.run_pure, mem_support_pure_iff] at hg
+  subst generated
+  rintro input ⟨payload, rfl⟩
+  exact treeRoot_cache_message_none parameter topLayer rootTree (otsSecret topLayer rootTree)
+    root.1 root.2 hroot payload
+
+abbrev CertificateGameResult := RetainedRestResult × (List Index × CertificateMonitorState)
+
+noncomputable def certificateGame (adversary : Adversary) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : SecretKey → CertificateStopRule) (stopped : Bool) : PMF CertificateGameResult := do
+  let generated ← (liftM (boundaryRun 0 scheme.keygen ∅) : PMF _)
+  let key := generated.1.1.2
+  (simulateQ (certificateProposalImpl key budget required (stopAfter key))
+    (retainedGameRestComputation adversary generated.1.1.1)).run
+      ([], generated.2, initialCertificateMonitor generated.1.2.hashCalls stopped)
+
+theorem certificateGame_cost_le (adversary : Adversary) (q : Nat) (required : Finset FtsTree)
+    (stopAfter : SecretKey → CertificateStopRule) (stopped : Bool)
+    (hbound : HasHashQueryBound scheme adversary q) (result : CertificateGameResult)
+    (hr : result ∈ (certificateGame adversary q required stopAfter stopped).support) :
+    result.2.2.2.spent ≤ q ∧ result.2.2.2.creationMass ≤ q := by
+  rw [certificateGame, PMF.monad_bind_eq_bind, PMF.mem_support_bind_iff] at hr
+  obtain ⟨generated, hgenerated, hr⟩ := hr
+  rw [probCompLift_support] at hgenerated
+  have hwhole : (scheme.keygen >>= fun keys => gameRest scheme adversary keys.1 keys.2).IsQueryBoundP
+      (· matches .inr _) q := hbound
+  have hkeygen := boundaryRun_bind_query_bound 0 scheme.keygen
+    (fun keys => gameRest scheme adversary keys.1 keys.2) q hwhole ∅ generated hgenerated
+  have hrest := hkeygen.2
+  rw [OtsProbeSimulation.gameRest_eq_map_retained, isQueryBoundP_map_iff] at hrest
+  have hcost := certificateProposal_run_cost_le generated.1.1.2 q required (stopAfter generated.1.1.2)
+    (retainedGameRestComputation adversary generated.1.1.1) (q - generated.1.2.hashCalls) hrest
+    ([], generated.2, initialCertificateMonitor generated.1.2.hashCalls stopped) result hr
+  simp only [initialCertificateMonitor, zero_add] at hcost
+  exact ⟨by omega, hcost.2.trans (Nat.cast_le.mpr (Nat.sub_le _ _))⟩
+
+theorem expected_certificateGame_creationMass_le_messageCalls (adversary : Adversary)
+    (budget : Nat) (required : Finset FtsTree) (stopAfter : SecretKey → CertificateStopRule) (stopped : Bool) :
+    (∑' result, Pr[= result | certificateGame adversary budget required stopAfter stopped] * result.2.2.2.creationMass) ≤
+      ∑' result, Pr[= result | certificateGame adversary budget required stopAfter stopped] * result.2.2.2.messageCalls := by
+  rw [certificateGame, tsum_probOutput_bind_mul, tsum_probOutput_bind_mul]
+  apply ENNReal.tsum_le_tsum
+  intro generated
+  exact mul_le_mul' le_rfl (expected_certificateProposal_creationMass_le_messageCalls generated.1.1.2 budget
+    generated.1.2.hashCalls required (stopAfter generated.1.1.2)
+    (retainedGameRestComputation adversary generated.1.1.1) generated.2 stopped)
+
+theorem expected_certificateGame_count_le_creationCost (adversary : Adversary)
+    (budget : Nat) (required : Finset FtsTree) (stopAfter : SecretKey → CertificateStopRule) (stopped : Bool) :
+    (∑' result, Pr[= result | certificateGame adversary budget required stopAfter stopped] *
+        certificateBankCount result.2.2.2.bank) ≤
+      ∑' result, Pr[= result | certificateGame adversary budget required stopAfter stopped] * result.2.2.2.creationCost := by
+  rw [certificateGame, tsum_probOutput_bind_mul, tsum_probOutput_bind_mul]
+  apply ENNReal.tsum_le_tsum
+  intro generated
+  by_cases hg : generated ∈ (liftM (boundaryRun 0 scheme.keygen ∅) : PMF _).support
+  · have hgenerated := hg
+    rw [probCompLift_support] at hgenerated
+    have hkeygen : (generated.1.1, generated.2) ∈ support ((simulateQ romImpl scheme.keygen).run ∅) := by
+      rw [← boundaryRun_forget 0 scheme.keygen ∅, support_map]
+      exact ⟨generated, hgenerated, rfl⟩
+    have hnone := keygen_cache_message_none (generated.1.1, generated.2) hkeygen
+    exact mul_le_mul' le_rfl (expected_certificateProposal_count_le_creationCost generated.1.1.2 budget
+      generated.1.2.hashCalls required (stopAfter generated.1.1.2)
+      (retainedGameRestComputation adversary generated.1.1.1) generated.2 stopped
+      hnone)
+  · have hzero : Pr[= generated | (liftM (boundaryRun 0 scheme.keygen ∅) : PMF _)] = 0 := by
+      rw [PMF.probOutput_eq_apply]
+      exact (PMF.apply_eq_zero_iff _ _).mpr hg
+    rw [hzero, zero_mul, zero_mul]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateJointExceptions.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateJointExceptions.lean
new file mode 100644
index 000000000..aba62dee3
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateJointExceptions.lean
@@ -0,0 +1,24 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CertificateCacheExceptionGame
+import SphincsSecurity.Proof.Fts.CertificateProposalPrefixException
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp ENNReal
+set_option backward.isDefEq.respectTransparency false
+
+def CertificateGameExceptional (result : CertificateCacheGameResult) : Prop :=
+  result.2.2.2.2 = true ∨
+    ProposalPrefixExceptional result.2.2.2.1.proposals result.2.2.2.1.log.length
+
+theorem expected_certificateCacheGame_project (adversary : Adversary) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : SecretKey → CertificateStopRule) (stopped : Bool)
+    (weight : CertificateGameResult → ENNReal) :
+    (∑' result, Pr[= result | certificateCacheGame adversary budget required stopAfter stopped] *
+      weight (certificateCacheGameProject result)) =
+        ∑' result, Pr[= result | certificateGame adversary budget required stopAfter stopped] * weight result := by
+  have h := congrArg (fun law : PMF CertificateGameResult => ∑' result, Pr[= result | law] * weight result)
+    (certificateCacheGame_project adversary budget required stopAfter stopped)
+  rw [tsum_probOutput_map_mul] at h
+  exact h
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateMessagePayment.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateMessagePayment.lean
new file mode 100644
index 000000000..90b161d74
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateMessagePayment.lean
@@ -0,0 +1,144 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CertificateMonitorStep
+import SphincsSecurity.Proof.Fts.DigestMessageCost
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (messageHashCharge)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem expected_originalProposalRecord_world_messageCalls (key : SecretKey)
+    (input : OracleWorld.Domain) (cache : QueryCache HashSpec) :
+    (∑' record, Pr[= record | originalProposalRecord key (.inl input) cache] *
+      record.trace.messageCalls.length) = hashQueryCharge (messageHashCharge key.parameter) cache input := by
+  rw [originalProposalRecord, ← PMF.monad_map_eq_map, tsum_probOutput_map_mul]
+  simp only [signingBoundaryTrace_messageCalls key.parameter input _ cache,
+    ENNReal.tsum_mul_right, tsum_probOutput_of_liftM_PMF, one_mul]
+
+theorem targetCreationMultiplier_le_expected_messageCalls (key : SecretKey)
+    (input : (OracleWorld + SigningSpec).Domain) (cache : QueryCache HashSpec) :
+    targetCreationMultiplier key cache input ≤
+      ∑' record, Pr[= record | originalProposalRecord key input cache] * record.trace.messageCalls.length := by
+  cases input with
+  | inl world =>
+      rw [expected_originalProposalRecord_world_messageCalls, targetCreationMultiplier]
+      cases world with
+      | inl sample => simp only [freshWorldTargetHashCost, Nat.cast_zero, hashQueryCharge, Sum.elim_inl, le_refl]
+      | inr input =>
+          by_cases hmessage : FtsProbeSimulation.MessageHashInput key.parameter input <;>
+            simp [freshWorldTargetHashCost, hashQueryCharge, messageHashCharge, hmessage]
+          split_ifs <;> norm_num
+  | inr message =>
+      rw [expected_originalProposalRecord_sign_messageCalls]
+      simpa only [targetCreationMultiplier, FtsLeaf, Fintype.card_fin] using
+        freshDigestSelection_mass_le_messageCharge key message cache
+
+noncomputable def certificateMonitorMessageCharge (key : SecretKey) (budget : Nat)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState) : ENNReal :=
+  if CertificateMonitorActive key budget input state then
+    ∑' record, Pr[= record | originalProposalRecord key input state.1] * record.trace.messageCalls.length
+  else 0
+
+theorem certificateMonitorMass_le_messageCharge (key : SecretKey) (budget : Nat)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState) :
+    certificateMonitorMass key budget input state ≤ certificateMonitorMessageCharge key budget input state := by
+  by_cases hactive : CertificateMonitorActive key budget input state
+  · simpa only [certificateMonitorMass, certificateMonitorMessageCharge, if_pos hactive] using
+      targetCreationMultiplier_le_expected_messageCalls key input state.1
+  · simp only [certificateMonitorMass, certificateMonitorMessageCharge, if_neg hactive, le_refl]
+
+theorem expected_certificateLengthImpl_of_record_function (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState)
+    (counter : CertificateMonitorState → ENNReal) (weight : ProposalExecutionRecord input → ENNReal)
+    (hadvance : ∀ length record, counter
+      (originalProposalAdvance (certificateMonitorUpdate key budget required stopAfter) input state length record) = weight record) :
+    (∑' result, Pr[= result | (certificateLengthImpl key budget required stopAfter input).run state] * counter result.2) =
+      ∑' record, Pr[= record | originalProposalRecord key input state.1] * weight record := by
+  simp only [certificateLengthImpl, originalLengthImpl, lengthRecordImpl, StateT.run_mk]
+  split
+  · rw [← PMF.monad_map_eq_map, tsum_probOutput_map_mul]
+    simp only [hadvance]
+    have h := congrArg (fun law : PMF (ProposalExecutionRecord input) =>
+      ∑' record, Pr[= record | law] * weight record)
+      (recordLengthBridge_record (originalProposalRecord key input state.1)
+        targetProposalAcceptance targetProposalAcceptance_ne_zero targetProposalAcceptance_lt_one.le)
+    rw [← PMF.monad_map_eq_map, tsum_probOutput_map_mul] at h
+    exact h
+  · rw [← PMF.monad_map_eq_map, tsum_probOutput_map_mul]
+    simp only [hadvance]
+
+theorem expected_certificateLengthImpl_messageCalls (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState) :
+    (∑' result, Pr[= result | (certificateLengthImpl key budget required stopAfter input).run state] *
+      result.2.2.messageCalls) = state.2.messageCalls + certificateMonitorMessageCharge key budget input state := by
+  by_cases hactive : CertificateMonitorActive key budget input state
+  · rw [expected_certificateLengthImpl_of_record_function key budget required stopAfter input state
+        (fun current => current.2.messageCalls)
+        (fun record => (state.2.messageCalls : ENNReal) + record.trace.messageCalls.length)
+        (fun length record => by simp only [originalProposalAdvance,
+          certificateMonitorUpdate_messageCalls key budget required stopAfter input state length record hactive, Nat.cast_add])]
+    simp only [certificateMonitorMessageCharge, if_pos hactive, mul_add, ENNReal.tsum_add,
+      ENNReal.tsum_mul_right, PMF.probOutput_eq_apply, PMF.tsum_coe, one_mul]
+  · rw [expected_certificateLengthImpl_of_advance_constant key budget required stopAfter input state
+        (fun current => current.2.messageCalls) state.2.messageCalls
+        (fun length record => by simp only [originalProposalAdvance,
+          certificateMonitorUpdate_inactive key budget required stopAfter input state length record hactive])]
+    simp only [certificateMonitorMessageCharge, if_neg hactive, add_zero]
+
+theorem expected_certificate_messageCalls {α : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (state : CertificateMonitorState) :
+    (∑' result, Pr[= result | (simulateQ (certificateLengthImpl key budget required stopAfter) computation).run state] *
+      result.2.2.messageCalls) = state.2.messageCalls +
+        expectedCertificateCharge key budget required stopAfter (certificateMonitorMessageCharge key budget) computation state :=
+  expected_certificate_accumulator key budget required stopAfter (fun current => current.2.messageCalls)
+    (certificateMonitorMessageCharge key budget) (expected_certificateLengthImpl_messageCalls key budget required stopAfter)
+    computation state
+
+theorem expectedCertificateCharge_mono {α : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (first second : (OracleWorld + SigningSpec).Domain → CertificateMonitorState → ENNReal)
+    (hle : ∀ input state, first input state ≤ second input state)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (state : CertificateMonitorState) :
+    expectedCertificateCharge key budget required stopAfter first computation state ≤
+      expectedCertificateCharge key budget required stopAfter second computation state := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [expectedCertificateCharge_pure, le_refl]
+  | query_bind input next ih =>
+      rw [expectedCertificateCharge_query_bind, expectedCertificateCharge_query_bind]
+      exact add_le_add (hle input state) (ENNReal.tsum_le_tsum fun result => mul_le_mul' le_rfl (ih result.1 result.2))
+
+theorem expected_certificate_creationMass_le_messageCalls {α : Type} (key : SecretKey) (budget spent : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (cache : QueryCache HashSpec) (stopped : Bool) :
+    (∑' result, Pr[= result | (simulateQ (certificateLengthImpl key budget required stopAfter) computation).run
+        (cache, initialCertificateMonitor spent stopped)] * result.2.2.creationMass) ≤
+      ∑' result, Pr[= result | (simulateQ (certificateLengthImpl key budget required stopAfter) computation).run
+        (cache, initialCertificateMonitor spent stopped)] * result.2.2.messageCalls := by
+  rw [expected_certificate_creationMass, expected_certificate_messageCalls]
+  simp only [initialCertificateMonitor, Nat.cast_zero, zero_add]
+  exact expectedCertificateCharge_mono key budget required stopAfter _ _
+    (certificateMonitorMass_le_messageCharge key budget) computation _
+
+theorem expected_certificateProposal_creationMass_le_messageCalls {α : Type} (key : SecretKey) (budget spent : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (cache : QueryCache HashSpec) (stopped : Bool) :
+    (∑' result, Pr[= result | (simulateQ (certificateProposalImpl key budget required stopAfter) computation).run
+        ([], cache, initialCertificateMonitor spent stopped)] * result.2.2.2.creationMass) ≤
+      ∑' result, Pr[= result | (simulateQ (certificateProposalImpl key budget required stopAfter) computation).run
+        ([], cache, initialCertificateMonitor spent stopped)] * result.2.2.2.messageCalls := by
+  have hmap := simulateQ_certificateProposalImpl_length key budget required stopAfter computation
+    ([], cache, initialCertificateMonitor spent stopped)
+  have hmass := congrArg (fun law : PMF (α × CertificateMonitorState) =>
+    ∑' result, Pr[= result | law] * result.2.2.creationMass) hmap
+  have hcalls := congrArg (fun law : PMF (α × CertificateMonitorState) =>
+    ∑' result, Pr[= result | law] * (result.2.2.messageCalls : ENNReal)) hmap
+  rw [tsum_probOutput_map_mul] at hmass hcalls
+  simp only [Prod.map] at hmass hcalls
+  rw [hmass, hcalls]
+  exact expected_certificate_creationMass_le_messageCalls key budget spent required stopAfter computation cache stopped
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateMonitor.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateMonitor.lean
new file mode 100644
index 000000000..0ee2dc849
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateMonitor.lean
@@ -0,0 +1,247 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.BankedProposalStep
+import SphincsSecurity.Proof.Fts.ValidInterleavedCover
+
+/-! ## SigningMacroBudget -/
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+
+def signingMacroHashCost : (OracleWorld + SigningSpec).Domain → Nat
+  | .inl (.inl _) => 0
+  | .inl (.inr _) => 1
+  | .inr _ => 1024
+
+end SphincsSecurity.Concrete
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+
+structure CertificateMonitor where
+  log : QueryLog SigningSpec
+  spent : Nat
+  messageCalls : Nat
+  proposals : Nat
+  creationMass : ENNReal
+  creationCost : ENNReal
+  bank : HashInput → Bool
+  stopped : Bool
+
+abbrev CertificateMonitorState := QueryCache HashSpec × CertificateMonitor
+
+def certificateMonitorCoverState (state : CertificateMonitorState) : CoverLogState :=
+  (state.1, state.2.log)
+
+def CertificateMonitorReady (key : SecretKey) (budget : Nat) (state : CertificateMonitorState) : Prop :=
+  SigningDigestsCached key.parameter state.1 key.root state.2.log ∧
+    ProposalCacheBound key state.1 state.2.spent ∧ state.2.spent ≤ budget
+
+def CertificateMonitorActive (key : SecretKey) (budget : Nat)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState) : Prop :=
+  state.2.stopped = false ∧ CertificateMonitorReady key budget state ∧
+    ValidSigningStep state.2.log input ∧ signingMacroHashCost input ≤ budget - state.2.spent
+
+abbrev CertificateStopRule := (input : (OracleWorld + SigningSpec).Domain) →
+  CertificateMonitorState → Nat → ProposalExecutionRecord input → Bool
+
+noncomputable def certificateMonitorEnabled (key : SecretKey) (budget : Nat)
+    (message : Message) (state : CertificateMonitorState) : Bool :=
+  decide (CertificateMonitorActive key budget (.inr message) state)
+
+noncomputable def certificateMonitorUpdate (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState)
+    (length : Nat) (record : ProposalExecutionRecord input) : CertificateMonitor :=
+  if CertificateMonitorActive key budget input state then
+    let after := proposalRecordLogState input state.2.log record
+    let next : CertificateMonitor :=
+      { log := after.2
+        spent := state.2.spent + record.trace.hashCalls
+        messageCalls := state.2.messageCalls + record.trace.messageCalls.length
+        proposals := state.2.proposals + length
+        creationMass := state.2.creationMass + targetCreationMultiplier key state.1 input
+        creationCost := state.2.creationCost + targetCreationMultiplier key state.1 input *
+          targetCreationPrice key nearUniformDigestReuseWeight (budget - state.2.spent)
+            (signatureLimit - state.2.log.length) required (certificateMonitorCoverState state)
+        bank := completedTargetBank key required after state.2.bank
+        stopped := false }
+    { next with stopped := (stopAfter input state length record || decide (¬ CertificateMonitorReady key budget (record.cache, next))) }
+  else { state.2 with stopped := true }
+
+noncomputable def certificateLengthImpl (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule) :
+    QueryImpl (OracleWorld + SigningSpec) (StateT CertificateMonitorState PMF) :=
+  originalLengthImpl key (fun state => state.2.spent) (certificateMonitorEnabled key budget)
+    (certificateMonitorUpdate key budget required stopAfter)
+
+noncomputable def certificateProposalImpl (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule) :
+    QueryImpl (OracleWorld + SigningSpec) (StateT (List Index × CertificateMonitorState) PMF) :=
+  originalProposalImpl key (fun state => state.2.spent) (certificateMonitorEnabled key budget)
+    (certificateMonitorUpdate key budget required stopAfter)
+
+noncomputable def certificateMonitorPotential (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (state : CertificateMonitorState) : ENNReal :=
+  bankedTargetEnvelope key nearUniformDigestReuseWeight (budget - state.2.spent)
+    (signatureLimit - state.2.log.length) required (certificateMonitorCoverState state) state.2.bank state.2.stopped
+
+noncomputable def certificateMonitorCharge (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (input : (OracleWorld + SigningSpec).Domain)
+    (state : CertificateMonitorState) : ENNReal :=
+  if CertificateMonitorActive key budget input state then
+    targetCreationMultiplier key state.1 input * targetCreationPrice key nearUniformDigestReuseWeight
+      (budget - state.2.spent) (signatureLimit - state.2.log.length) required (certificateMonitorCoverState state)
+  else 0
+
+noncomputable def certificateMonitorMass (key : SecretKey) (budget : Nat)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState) : ENNReal :=
+  if CertificateMonitorActive key budget input state then targetCreationMultiplier key state.1 input else 0
+
+def initialCertificateMonitor (spent : Nat) (stopped : Bool := false) : CertificateMonitor :=
+  { log := []
+    spent := spent
+    messageCalls := 0
+    proposals := 0
+    creationMass := 0
+    creationCost := 0
+    bank := fun _ => false
+    stopped := stopped }
+
+theorem certificateMonitorUpdate_creationCost (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState)
+    (length : Nat) (record : ProposalExecutionRecord input) :
+    (certificateMonitorUpdate key budget required stopAfter input state length record).creationCost =
+      state.2.creationCost + certificateMonitorCharge key budget required input state := by
+  by_cases hactive : CertificateMonitorActive key budget input state <;>
+    simp only [certificateMonitorUpdate, certificateMonitorCharge, hactive, if_true, if_false, add_zero]
+
+theorem certificateMonitorUpdate_creationMass (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState)
+    (length : Nat) (record : ProposalExecutionRecord input) :
+    (certificateMonitorUpdate key budget required stopAfter input state length record).creationMass =
+      state.2.creationMass + certificateMonitorMass key budget input state := by
+  by_cases hactive : CertificateMonitorActive key budget input state <;>
+    simp only [certificateMonitorUpdate, certificateMonitorMass, hactive, if_true, if_false, add_zero]
+
+theorem certificateMonitorPotential_initial (key : SecretKey) (budget spent : Nat)
+    (required : Finset FtsTree) (cache : QueryCache HashSpec) (stopped : Bool)
+    (hnone : ∀ input, FtsProbeSimulation.MessageHashInput key.parameter input → cache input = none) :
+    certificateMonitorPotential key budget required (cache, initialCertificateMonitor spent stopped) = 0 := by
+  cases stopped with
+  | false => exact bankedTargetEnvelope_initial key _ _ _ required _ hnone
+  | true => simp only [certificateMonitorPotential, initialCertificateMonitor, bankedTargetEnvelope_stopped, certificateBankCount_empty]
+
+theorem certificateMonitorUpdate_inactive (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState)
+    (length : Nat) (record : ProposalExecutionRecord input)
+    (hactive : ¬ CertificateMonitorActive key budget input state) :
+    certificateMonitorUpdate key budget required stopAfter input state length record = { state.2 with stopped := true } := by
+  rw [certificateMonitorUpdate, if_neg hactive]
+
+theorem certificateMonitorUpdate_spent (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState)
+    (length : Nat) (record : ProposalExecutionRecord input)
+    (hactive : CertificateMonitorActive key budget input state) :
+    (certificateMonitorUpdate key budget required stopAfter input state length record).spent =
+      state.2.spent + record.trace.hashCalls := by
+  simp only [certificateMonitorUpdate, if_pos hactive]
+
+theorem certificateMonitorUpdate_messageCalls (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState)
+    (length : Nat) (record : ProposalExecutionRecord input)
+    (hactive : CertificateMonitorActive key budget input state) :
+    (certificateMonitorUpdate key budget required stopAfter input state length record).messageCalls =
+      state.2.messageCalls + record.trace.messageCalls.length := by
+  simp only [certificateMonitorUpdate, if_pos hactive]
+
+theorem certificateMonitorPotential_advance_active (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState)
+    (length : Nat) (record : ProposalExecutionRecord input)
+    (hactive : CertificateMonitorActive key budget input state) :
+    certificateMonitorPotential key budget required
+      (originalProposalAdvance (certificateMonitorUpdate key budget required stopAfter) input state length record) =
+      bankedProposalRecordValue key nearUniformDigestReuseWeight (budget - state.2.spent)
+        (signatureLimit - (state.2.log ++ signingLogFragment input record.output).length)
+        required (certificateMonitorCoverState state) state.2.bank input record
+        (certificateMonitorUpdate key budget required stopAfter input state length record).stopped := by
+  simp only [certificateMonitorPotential, originalProposalAdvance, certificateMonitorUpdate, if_pos hactive,
+    bankedProposalRecordValue, proposalRecordLogState, certificateMonitorCoverState, Nat.sub_sub]
+
+theorem certificateMonitorPotential_advance_inactive (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState)
+    (length : Nat) (record : ProposalExecutionRecord input)
+    (hactive : ¬ CertificateMonitorActive key budget input state) :
+    certificateMonitorPotential key budget required
+      (originalProposalAdvance (certificateMonitorUpdate key budget required stopAfter) input state length record) =
+      certificateBankCount state.2.bank := by
+  simp only [certificateMonitorPotential, originalProposalAdvance, certificateMonitorUpdate_inactive key budget
+    required stopAfter input state length record hactive, bankedTargetEnvelope_stopped]
+
+theorem certificateMonitor_sign_proposals_active (key : SecretKey) (budget : Nat)
+    (message : Message) (state : CertificateMonitorState) :
+    originalProposalActive key (fun state : CertificateMonitorState => state.2.spent)
+      (certificateMonitorEnabled key budget) (.inr message) state =
+        decide (CertificateMonitorActive key budget (.inr message) state) := by
+  by_cases hactive : CertificateMonitorActive key budget (.inr message) state
+  · simp only [originalProposalActive, certificateMonitorEnabled, hactive, decide_true,
+      hactive.2.1.2.1, Bool.true_and]
+  · simp only [originalProposalActive, certificateMonitorEnabled, hactive, decide_false, Bool.false_and]
+
+theorem certificateLengthImpl_world_run (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule) (input : OracleWorld.Domain)
+    (state : CertificateMonitorState) :
+    (certificateLengthImpl key budget required stopAfter (.inl input)).run state =
+      (originalProposalRecord key (.inl input) state.1).map (fun record =>
+        (record.output, originalProposalAdvance (certificateMonitorUpdate key budget required stopAfter)
+          (.inl input) state 0 record)) := by
+  simp only [certificateLengthImpl, originalLengthImpl, lengthRecordImpl, originalProposalActive,
+    StateT.run_mk, Bool.false_eq_true, if_false]
+
+theorem certificateLengthImpl_sign_run (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule) (message : Message)
+    (state : CertificateMonitorState) :
+    (certificateLengthImpl key budget required stopAfter (.inr message)).run state =
+      if CertificateMonitorActive key budget (.inr message) state then
+        (recordLengthBridge (originalProposalRecord key (.inr message) state.1)
+          targetProposalAcceptance targetProposalAcceptance_ne_zero targetProposalAcceptance_lt_one.le).map
+            (fun result => (result.2.output, originalProposalAdvance (certificateMonitorUpdate key budget required stopAfter)
+              (.inr message) state result.1 result.2))
+      else (originalProposalRecord key (.inr message) state.1).map (fun record =>
+        (record.output, originalProposalAdvance (certificateMonitorUpdate key budget required stopAfter)
+          (.inr message) state 0 record)) := by
+  simp only [certificateLengthImpl, originalLengthImpl, lengthRecordImpl, StateT.run_mk,
+    certificateMonitor_sign_proposals_active, decide_eq_true_eq]
+
+theorem certificateLengthImpl_inactive_run (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState)
+    (hactive : ¬ CertificateMonitorActive key budget input state) :
+    (certificateLengthImpl key budget required stopAfter input).run state =
+      (originalProposalRecord key input state.1).map (fun record =>
+        (record.output, (record.cache, { state.2 with stopped := true }))) := by
+  cases input with
+  | inl world =>
+      simp only [certificateLengthImpl_world_run, originalProposalAdvance,
+        certificateMonitorUpdate_inactive key budget required stopAfter (.inl world) state 0 _ hactive]
+  | inr message =>
+      simp only [certificateLengthImpl_sign_run, if_neg hactive, originalProposalAdvance,
+        certificateMonitorUpdate_inactive key budget required stopAfter (.inr message) state 0 _ hactive]
+
+theorem simulateQ_certificateProposalImpl_length {α : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (state : List Index × CertificateMonitorState) :
+    Prod.map id Prod.snd <$> (simulateQ (certificateProposalImpl key budget required stopAfter) computation).run state =
+      (simulateQ (certificateLengthImpl key budget required stopAfter) computation).run state.2 :=
+  simulateQ_originalProposalImpl_length _ _ _ _ _ _
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateMonitorStep.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateMonitorStep.lean
new file mode 100644
index 000000000..b2ae61449
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateMonitorStep.lean
@@ -0,0 +1,221 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CertificateMonitor
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+
+theorem expected_certificateLengthImpl_potential_le (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState) :
+    (∑' result, Pr[= result | (certificateLengthImpl key budget required stopAfter input).run state] *
+      certificateMonitorPotential key budget required result.2) ≤
+      certificateMonitorPotential key budget required state + certificateMonitorCharge key budget required input state := by
+  by_cases hactive : CertificateMonitorActive key budget input state
+  · have hdata := hactive
+    obtain ⟨hlive, ⟨hsigned, hcache, _⟩, hvalid, hcost⟩ := hdata
+    rw [certificateMonitorCharge, if_pos hactive]
+    cases input with
+    | inl world =>
+        rw [certificateLengthImpl_world_run, ← PMF.monad_map_eq_map, tsum_probOutput_map_mul]
+        simp only [certificateMonitorPotential_advance_active key budget required stopAfter (.inl world) state 0 _ hactive,
+          signingLogFragment, List.append_nil]
+        have hcost' : signingExecutionHashCost (.inl world) ≤ budget - state.2.spent := by
+          cases world <;> exact hcost
+        have h := expected_originalProposalRecord_world_banked_le key nearUniformDigestReuseWeight
+          (budget - state.2.spent) (signatureLimit - state.2.log.length) required
+          (certificateMonitorCoverState state) state.2.bank world
+          (fun record => (certificateMonitorUpdate key budget required stopAfter (.inl world) state 0 record).stopped)
+          hsigned hcost'
+        simpa only [certificateMonitorPotential, certificateMonitorCoverState, hlive] using h
+    | inr message =>
+        rw [certificateLengthImpl_sign_run, if_pos hactive, ← PMF.monad_map_eq_map, tsum_probOutput_map_mul]
+        simp only [certificateMonitorPotential_advance_active key budget required stopAfter (.inr message) state _ _ hactive,
+          signingLogFragment, List.length_append, List.length_singleton]
+        have hremaining : signatureLimit - (state.2.log.length + 1) + 1 = signatureLimit - state.2.log.length := by
+          change state.2.log.length < signatureLimit at hvalid
+          omega
+        have hreuse := exactDigestReuseWeight_le_near_uniform_of_clean_cache key state.1 state.2.spent
+          hcache.spent_le hcache.cache_le hcache.no_deficit message
+        have h := expected_lengthBridge_sign_banked_le key nearUniformDigestReuseWeight
+          (budget - state.2.spent) (signatureLimit - (state.2.log.length + 1)) required
+          (certificateMonitorCoverState state) state.2.bank message
+          (fun result => (certificateMonitorUpdate key budget required stopAfter (.inr message) state result.1 result.2).stopped)
+          hsigned hreuse
+        rw [hremaining] at h
+        simpa only [certificateMonitorPotential, certificateMonitorCoverState, hlive] using h
+  · rw [certificateMonitorCharge, if_neg hactive, add_zero, certificateLengthImpl_inactive_run key budget required stopAfter input state hactive,
+      ← PMF.monad_map_eq_map, tsum_probOutput_map_mul]
+    simp only [certificateMonitorPotential, bankedTargetEnvelope_stopped]
+    rw [ENNReal.tsum_mul_right]
+    have hmass : (∑' record, Pr[= record | originalProposalRecord key input state.1]) = 1 := by
+      simp only [PMF.probOutput_eq_apply, PMF.tsum_coe]
+    rw [hmass, one_mul]
+    exact certificateBankCount_le_bankedCacheWeight _ _ _ _ _
+
+theorem expected_certificateLengthImpl_of_advance_constant (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState)
+    (counter : CertificateMonitorState → ENNReal) (value : ENNReal)
+    (hadvance : ∀ length record, counter
+      (originalProposalAdvance (certificateMonitorUpdate key budget required stopAfter) input state length record) = value) :
+    (∑' result, Pr[= result | (certificateLengthImpl key budget required stopAfter input).run state] * counter result.2) = value := by
+  simp only [certificateLengthImpl, originalLengthImpl, lengthRecordImpl, StateT.run_mk]
+  split <;> rw [← PMF.monad_map_eq_map, tsum_probOutput_map_mul] <;>
+    simp only [hadvance, ENNReal.tsum_mul_right, PMF.probOutput_eq_apply, PMF.tsum_coe, one_mul]
+
+theorem expected_certificateLengthImpl_creationCost (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState) :
+    (∑' result, Pr[= result | (certificateLengthImpl key budget required stopAfter input).run state] * result.2.2.creationCost) =
+      state.2.creationCost + certificateMonitorCharge key budget required input state :=
+  expected_certificateLengthImpl_of_advance_constant key budget required stopAfter input state
+    (fun current => current.2.creationCost) _ (certificateMonitorUpdate_creationCost key budget required stopAfter input state)
+
+theorem expected_certificateLengthImpl_creationMass (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState) :
+    (∑' result, Pr[= result | (certificateLengthImpl key budget required stopAfter input).run state] * result.2.2.creationMass) =
+      state.2.creationMass + certificateMonitorMass key budget input state :=
+  expected_certificateLengthImpl_of_advance_constant key budget required stopAfter input state
+    (fun current => current.2.creationMass) _ (certificateMonitorUpdate_creationMass key budget required stopAfter input state)
+
+noncomputable def expectedCertificateCharge {α : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (charge : (OracleWorld + SigningSpec).Domain → CertificateMonitorState → ENNReal)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) : CertificateMonitorState → ENNReal :=
+  OracleComp.construct (fun _ _ => 0)
+    (fun input _ next state => charge input state +
+      ∑' result, Pr[= result | (certificateLengthImpl key budget required stopAfter input).run state] *
+        next result.1 result.2) computation
+
+@[simp] theorem expectedCertificateCharge_pure {α : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (charge : (OracleWorld + SigningSpec).Domain → CertificateMonitorState → ENNReal)
+    (value : α) (state : CertificateMonitorState) :
+    expectedCertificateCharge key budget required stopAfter charge (pure value) state = 0 := rfl
+
+theorem expectedCertificateCharge_query_bind {α : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (charge : (OracleWorld + SigningSpec).Domain → CertificateMonitorState → ENNReal)
+    (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α)
+    (state : CertificateMonitorState) :
+    expectedCertificateCharge key budget required stopAfter charge (OracleSpec.query input >>= next) state =
+      charge input state +
+        ∑' result, Pr[= result | (certificateLengthImpl key budget required stopAfter input).run state] *
+          expectedCertificateCharge key budget required stopAfter charge (next result.1) result.2 := rfl
+
+theorem expected_certificate_accumulator {α : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (counter : CertificateMonitorState → ENNReal)
+    (charge : (OracleWorld + SigningSpec).Domain → CertificateMonitorState → ENNReal)
+    (hstep : ∀ input state,
+      (∑' result, Pr[= result | (certificateLengthImpl key budget required stopAfter input).run state] * counter result.2) =
+        counter state + charge input state)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (state : CertificateMonitorState) :
+    (∑' result, Pr[= result | (simulateQ (certificateLengthImpl key budget required stopAfter) computation).run state] * counter result.2) =
+      counter state + expectedCertificateCharge key budget required stopAfter charge computation state := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [simulateQ_pure, StateT.run_pure, tsum_probOutput_pure_mul,
+      expectedCertificateCharge_pure, add_zero]
+  | query_bind input next ih =>
+      rw [simulateQ_bind, simulateQ_spec_query, StateT.run_bind, tsum_probOutput_bind_mul,
+        expectedCertificateCharge_query_bind]
+      simp_rw [ih, mul_add, ENNReal.tsum_add]
+      rw [hstep, add_assoc]
+
+theorem expected_certificate_creationCost {α : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (state : CertificateMonitorState) :
+    (∑' result, Pr[= result | (simulateQ (certificateLengthImpl key budget required stopAfter) computation).run state] * result.2.2.creationCost) =
+      state.2.creationCost +
+        expectedCertificateCharge key budget required stopAfter (certificateMonitorCharge key budget required) computation state :=
+  expected_certificate_accumulator key budget required stopAfter (fun current => current.2.creationCost)
+    (certificateMonitorCharge key budget required) (expected_certificateLengthImpl_creationCost key budget required stopAfter)
+    computation state
+
+theorem expected_certificate_creationMass {α : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (state : CertificateMonitorState) :
+    (∑' result, Pr[= result | (simulateQ (certificateLengthImpl key budget required stopAfter) computation).run state] * result.2.2.creationMass) =
+      state.2.creationMass + expectedCertificateCharge key budget required stopAfter (certificateMonitorMass key budget) computation state :=
+  expected_certificate_accumulator key budget required stopAfter (fun current => current.2.creationMass)
+    (certificateMonitorMass key budget) (expected_certificateLengthImpl_creationMass key budget required stopAfter)
+    computation state
+
+theorem expected_certificate_potential_le_initial_add_charge {α : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (state : CertificateMonitorState) :
+    (∑' result, Pr[= result | (simulateQ (certificateLengthImpl key budget required stopAfter) computation).run state] *
+      certificateMonitorPotential key budget required result.2) ≤
+      certificateMonitorPotential key budget required state +
+        expectedCertificateCharge key budget required stopAfter (certificateMonitorCharge key budget required) computation state := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [simulateQ_pure, StateT.run_pure, tsum_probOutput_pure_mul,
+      expectedCertificateCharge_pure, add_zero, le_refl]
+  | query_bind input next ih =>
+      rw [simulateQ_bind, simulateQ_spec_query, StateT.run_bind, tsum_probOutput_bind_mul,
+        expectedCertificateCharge_query_bind]
+      calc
+        _ ≤ ∑' result, Pr[= result | (certificateLengthImpl key budget required stopAfter input).run state] *
+            (certificateMonitorPotential key budget required result.2 +
+              expectedCertificateCharge key budget required stopAfter (certificateMonitorCharge key budget required)
+                (next result.1) result.2) :=
+          ENNReal.tsum_le_tsum fun result => mul_le_mul' le_rfl (ih result.1 result.2)
+        _ = (∑' result, Pr[= result | (certificateLengthImpl key budget required stopAfter input).run state] *
+            certificateMonitorPotential key budget required result.2) +
+            ∑' result, Pr[= result | (certificateLengthImpl key budget required stopAfter input).run state] *
+              expectedCertificateCharge key budget required stopAfter (certificateMonitorCharge key budget required)
+                (next result.1) result.2 := by simp only [mul_add, ENNReal.tsum_add]
+        _ ≤ (certificateMonitorPotential key budget required state + certificateMonitorCharge key budget required input state) +
+            ∑' result, Pr[= result | (certificateLengthImpl key budget required stopAfter input).run state] *
+              expectedCertificateCharge key budget required stopAfter (certificateMonitorCharge key budget required)
+                (next result.1) result.2 :=
+          add_le_add (expected_certificateLengthImpl_potential_le key budget required stopAfter input state) le_rfl
+        _ = _ := by rw [add_assoc]
+
+theorem expected_certificate_count_le_initial_add_charge {α : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (state : CertificateMonitorState) :
+    (∑' result, Pr[= result | (simulateQ (certificateLengthImpl key budget required stopAfter) computation).run state] *
+      certificateBankCount result.2.2.bank) ≤
+      certificateMonitorPotential key budget required state +
+        expectedCertificateCharge key budget required stopAfter (certificateMonitorCharge key budget required) computation state := by
+  apply le_trans ?_ (expected_certificate_potential_le_initial_add_charge key budget required stopAfter computation state)
+  exact ENNReal.tsum_le_tsum fun result => mul_le_mul' le_rfl (certificateBankCount_le_bankedCacheWeight _ _ _ _ _)
+
+theorem expected_certificate_count_le_creationCost {α : Type} (key : SecretKey) (budget spent : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (cache : QueryCache HashSpec) (stopped : Bool)
+    (hnone : ∀ input, FtsProbeSimulation.MessageHashInput key.parameter input → cache input = none) :
+    (∑' result, Pr[= result | (simulateQ (certificateLengthImpl key budget required stopAfter) computation).run
+        (cache, initialCertificateMonitor spent stopped)] * certificateBankCount result.2.2.bank) ≤
+      ∑' result, Pr[= result | (simulateQ (certificateLengthImpl key budget required stopAfter) computation).run
+        (cache, initialCertificateMonitor spent stopped)] * result.2.2.creationCost := by
+  rw [expected_certificate_creationCost]
+  have h := expected_certificate_count_le_initial_add_charge key budget required stopAfter computation
+    (cache, initialCertificateMonitor spent stopped)
+  rw [certificateMonitorPotential_initial key budget spent required cache stopped hnone, zero_add] at h
+  simpa only [initialCertificateMonitor, zero_add] using h
+
+theorem expected_certificateProposal_count_le_creationCost {α : Type} (key : SecretKey) (budget spent : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (cache : QueryCache HashSpec) (stopped : Bool)
+    (hnone : ∀ input, FtsProbeSimulation.MessageHashInput key.parameter input → cache input = none) :
+    (∑' result, Pr[= result | (simulateQ (certificateProposalImpl key budget required stopAfter) computation).run
+        ([], cache, initialCertificateMonitor spent stopped)] * certificateBankCount result.2.2.2.bank) ≤
+      ∑' result, Pr[= result | (simulateQ (certificateProposalImpl key budget required stopAfter) computation).run
+        ([], cache, initialCertificateMonitor spent stopped)] * result.2.2.2.creationCost := by
+  have hmap := simulateQ_certificateProposalImpl_length key budget required stopAfter computation
+    ([], cache, initialCertificateMonitor spent stopped)
+  have hcount := congrArg (fun law : PMF (α × CertificateMonitorState) =>
+    ∑' result, Pr[= result | law] * certificateBankCount result.2.2.bank) hmap
+  have hcost := congrArg (fun law : PMF (α × CertificateMonitorState) =>
+    ∑' result, Pr[= result | law] * result.2.2.creationCost) hmap
+  rw [tsum_probOutput_map_mul] at hcount hcost
+  simp only [Prod.map] at hcount hcost
+  rw [hcount, hcost]
+  exact expected_certificate_count_le_creationCost key budget spent required stopAfter computation cache stopped hnone
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateOriginalMessageCost.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateOriginalMessageCost.lean
new file mode 100644
index 000000000..79e3e031b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateOriginalMessageCost.lean
@@ -0,0 +1,78 @@
+import SphincsSecurity.Proof.Fts.CertificateMessagePayment
+import SphincsSecurity.Proof.Fts.OriginalProposalBudget
+import SphincsSecurity.Proof.Fts.CertificateCacheMonitor
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+private theorem probOutput_probCompLift {Result : Type} (computation : ProbComp Result) (result : Result) :
+    Pr[= result | (liftM computation : PMF Result)] = Pr[= result | computation] := rfl
+
+theorem certificateLengthImpl_original_cache (key : SecretKey) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : CertificateStopRule) (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState) :
+    (fun result => (result.1, result.2.1)) <$> (certificateLengthImpl key budget required stopAfter input).run state =
+      (liftM ((simulateQ romImpl (expandedAdversaryImpl key input)).run state.1) : PMF _) := by
+  have h := simulateQ_originalLengthImpl_forget key (fun current => current.2.spent) (certificateMonitorEnabled key budget)
+    (certificateMonitorUpdate key budget required stopAfter) (OracleSpec.query input) state
+  simp only [simulateQ_spec_query, ← originalProposalRecord_project] at h
+  have hb := congrArg (Functor.map (fun result => (result.1.1, result.2))) (originalProposalRecord_boundary key input state.1)
+  simp only [← PMF.monad_map_eq_map, Functor.map_map, ← liftM_map (m := ProbComp) (n := PMF), boundaryRun_forget] at hb
+  exact h.trans hb
+
+theorem certificateMonitorMessageCharge_le_original (key : SecretKey) (budget : Nat)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState) :
+    certificateMonitorMessageCharge key budget input state ≤
+      expectedBoundaryMessageCalls key.parameter (expandedAdversaryImpl key input) state.1 := by
+  have h := congrArg (fun law => ∑' result, Pr[= result | law] * (result.1.2.messageCalls.length : ENNReal))
+    (originalProposalRecord_boundary key input state.1)
+  simp only [← PMF.monad_map_eq_map, tsum_probOutput_map_mul, probOutput_probCompLift] at h
+  rw [certificateMonitorMessageCharge]
+  split_ifs
+  · exact h.le
+  · exact bot_le
+
+theorem expectedCertificateMessageCharge_le_original {Result : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) (state : CertificateMonitorState) :
+    expectedCertificateCharge key budget required stopAfter (certificateMonitorMessageCharge key budget) computation state ≤
+      expectedBoundaryMessageCalls key.parameter (simulateQ (expandedAdversaryImpl key) computation) state.1 := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [expectedCertificateCharge_pure, simulateQ_pure, expectedBoundaryMessageCalls_pure, le_refl]
+  | query_bind input next ih =>
+      rw [expectedCertificateCharge_query_bind, simulateQ_bind, simulateQ_spec_query, expectedBoundaryMessageCalls_bind]
+      apply add_le_add (certificateMonitorMessageCharge_le_original key budget input state)
+      have h := congrArg (fun law => ∑' result, Pr[= result | law] *
+        expectedBoundaryMessageCalls key.parameter (simulateQ (expandedAdversaryImpl key) (next result.1)) result.2)
+        (certificateLengthImpl_original_cache key budget required stopAfter input state)
+      simp only [tsum_probOutput_map_mul, probOutput_probCompLift] at h
+      calc
+        _ ≤ ∑' result, Pr[= result | (certificateLengthImpl key budget required stopAfter input).run state] *
+            expectedBoundaryMessageCalls key.parameter (simulateQ (expandedAdversaryImpl key) (next result.1)) result.2.1 :=
+          ENNReal.tsum_le_tsum fun result => mul_le_mul' le_rfl (ih result.1 result.2)
+        _ = _ := h
+
+theorem expected_certificateLength_messageCalls_le_original {Result : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) (state : CertificateMonitorState) :
+    (∑' result, Pr[= result | (simulateQ (certificateLengthImpl key budget required stopAfter) computation).run state] *
+      (result.2.2.messageCalls : ENNReal)) ≤ (state.2.messageCalls : ENNReal) +
+        expectedBoundaryMessageCalls key.parameter (simulateQ (expandedAdversaryImpl key) computation) state.1 := by
+  rw [expected_certificate_messageCalls]
+  exact add_le_add le_rfl (expectedCertificateMessageCharge_le_original key budget required stopAfter computation state)
+
+theorem expected_certificateCacheProposal_messageCalls_le_original {Result : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) (state : List Index × CertificateCacheMonitorState) :
+    (∑' result, Pr[= result | (simulateQ (certificateCacheProposalImpl key budget required stopAfter) computation).run state] *
+      (result.2.2.2.1.messageCalls : ENNReal)) ≤ (state.2.2.1.messageCalls : ENNReal) +
+        expectedBoundaryMessageCalls key.parameter (simulateQ (expandedAdversaryImpl key) computation) state.2.1 := by
+  have h := expected_certificateLength_messageCalls_le_original key budget required stopAfter computation
+    (certificateCacheMonitorProject state.2)
+  rw [← simulateQ_certificateProposalImpl_length key budget required stopAfter computation
+    (state.1, certificateCacheMonitorProject state.2), tsum_probOutput_map_mul] at h
+  rw [← simulateQ_certificateCacheProposalImpl_project key budget required stopAfter computation state, tsum_probOutput_map_mul] at h
+  exact h
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CertificatePathBudget.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificatePathBudget.lean
new file mode 100644
index 000000000..136d428bc
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificatePathBudget.lean
@@ -0,0 +1,89 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CertificateMonitor
+import SphincsSecurity.Proof.Fts.OriginalProposalBudget
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem certificateLengthImpl_support (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState)
+    (result : (OracleWorld + SigningSpec).Range input × CertificateMonitorState)
+    (hr : result ∈ ((certificateLengthImpl key budget required stopAfter input).run state).support) :
+    ∃ length record, record ∈ (originalProposalRecord key input state.1).support ∧
+      result = (record.output, originalProposalAdvance
+        (certificateMonitorUpdate key budget required stopAfter) input state length record) := by
+  simp only [certificateLengthImpl, originalLengthImpl, lengthRecordImpl, StateT.run_mk] at hr
+  split at hr
+  · rw [PMF.mem_support_map_iff] at hr
+    obtain ⟨source, hsource, rfl⟩ := hr
+    have hrecord := (PMF.mem_support_map_iff Prod.snd _ _).mpr ⟨source, hsource, rfl⟩
+    rw [recordLengthBridge_record] at hrecord
+    exact ⟨source.1, source.2, hrecord, rfl⟩
+  · rw [PMF.mem_support_map_iff] at hr
+    obtain ⟨record, hrecord, rfl⟩ := hr
+    exact ⟨0, record, hrecord, rfl⟩
+
+theorem certificateMonitorUpdate_le_hashCalls (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState)
+    (length : Nat) (record : ProposalExecutionRecord input)
+    (hr : record ∈ (originalProposalRecord key input state.1).support) :
+    (certificateMonitorUpdate key budget required stopAfter input state length record).spent ≤
+        state.2.spent + record.trace.hashCalls ∧
+      (certificateMonitorUpdate key budget required stopAfter input state length record).creationMass ≤
+        state.2.creationMass + record.trace.hashCalls := by
+  by_cases hactive : CertificateMonitorActive key budget input state
+  · simp only [certificateMonitorUpdate, if_pos hactive]
+    exact ⟨le_rfl, add_le_add le_rfl (targetCreationMultiplier_le_record_hashCalls key input state.1 record hr)⟩
+  · simp only [certificateMonitorUpdate, if_neg hactive]
+    exact ⟨Nat.le_add_right _ _, le_self_add⟩
+
+theorem certificateLength_run_cost_le {α : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (q : Nat)
+    (hbound : (simulateQ (expandedAdversaryImpl key) computation).IsQueryBoundP (· matches .inr _) q)
+    (state : CertificateMonitorState) (result : α × CertificateMonitorState)
+    (hr : result ∈ ((simulateQ (certificateLengthImpl key budget required stopAfter) computation).run state).support) :
+    result.2.2.spent ≤ state.2.spent + q ∧ result.2.2.creationMass ≤ state.2.creationMass + q := by
+  induction computation using OracleComp.inductionOn generalizing q state result with
+  | pure value =>
+      simp only [simulateQ_pure, StateT.run_pure, PMF.monad_pure_eq_pure, PMF.mem_support_pure_iff] at hr
+      subst result
+      exact ⟨Nat.le_add_right _ _, le_self_add⟩
+  | query_bind input next ih =>
+      rw [simulateQ_bind, simulateQ_spec_query, StateT.run_bind, PMF.monad_bind_eq_bind,
+        PMF.mem_support_bind_iff] at hr
+      obtain ⟨middle, hmiddle, hr⟩ := hr
+      obtain ⟨length, record, hrecord, rfl⟩ :=
+        certificateLengthImpl_support key budget required stopAfter input state middle hmiddle
+      have hquery := originalProposalRecord_query_bound key input next q hbound state.1 record hrecord
+      have hstep := certificateMonitorUpdate_le_hashCalls key budget required stopAfter input state length record hrecord
+      have htail := ih record.output _ hquery.2 _ result hr
+      simp only [originalProposalAdvance] at htail
+      constructor
+      · omega
+      · calc
+          _ ≤ (certificateMonitorUpdate key budget required stopAfter input state length record).creationMass +
+              (q - record.trace.hashCalls : Nat) := htail.2
+          _ ≤ (state.2.creationMass + record.trace.hashCalls) + (q - record.trace.hashCalls : Nat) :=
+            add_le_add hstep.2 le_rfl
+          _ = state.2.creationMass + q := by
+            rw [add_assoc, ← Nat.cast_add, Nat.add_sub_of_le hquery.1]
+
+theorem certificateProposal_run_cost_le {α : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (q : Nat)
+    (hbound : (simulateQ (expandedAdversaryImpl key) computation).IsQueryBoundP (· matches .inr _) q)
+    (state : List Index × CertificateMonitorState) (result : α × (List Index × CertificateMonitorState))
+    (hr : result ∈ ((simulateQ (certificateProposalImpl key budget required stopAfter) computation).run state).support) :
+    result.2.2.2.spent ≤ state.2.2.spent + q ∧
+      result.2.2.2.creationMass ≤ state.2.2.creationMass + q := by
+  have hprojection := simulateQ_certificateProposalImpl_length key budget required stopAfter computation state
+  have hm := (PMF.mem_support_map_iff (Prod.map id Prod.snd) _ _).mpr ⟨result, hr, rfl⟩
+  rw [← PMF.monad_map_eq_map, hprojection] at hm
+  exact certificateLength_run_cost_le key budget required stopAfter computation q hbound state.2 _ hm
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateProposalInvariant.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateProposalInvariant.lean
new file mode 100644
index 000000000..a3acd6887
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateProposalInvariant.lean
@@ -0,0 +1,249 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.ProposalPrefixStop
+import SphincsSecurity.Proof.Fts.TerminalProposalEnvelope
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (messageAnswers)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem originalProposalRecord_cache_le (key : SecretKey)
+    (input : (OracleWorld + SigningSpec).Domain) (cache : QueryCache HashSpec)
+    (record : ProposalExecutionRecord input) (hr : record ∈ (originalProposalRecord key input cache).support) :
+    cache ≤ record.cache := by
+  have hm := (PMF.mem_support_map_iff (fun record : ProposalExecutionRecord input =>
+    (record.output, record.cache)) _ _).mpr ⟨record, hr, rfl⟩
+  rw [originalProposalRecord_project, originalAdversaryPMFImpl_run, probCompLift_support] at hm
+  exact unloggedMappedAdversaryImpl_cache_le key input cache (record.output, record.cache) hm
+
+theorem originalProposalRecord_sign_observed_index (key : SecretKey) (message : Message)
+    (cache : QueryCache HashSpec) (record : ProposalExecutionRecord (.inr message))
+    (hr : record ∈ (originalProposalRecord key (.inr message) cache).support) (view : FewTimeView)
+    (hview : observedSigningView? (messageAnswers key.parameter record.cache) key.root
+      ⟨message, record.output⟩ = some view) : record.index = view.1 := by
+  rw [originalProposalRecord, PMF.mem_support_map_iff] at hr
+  obtain ⟨source, hsource, rfl⟩ := hr
+  have ht := (PMF.mem_support_map_iff Prod.fst _ _).mpr ⟨source, hsource, rfl⟩
+  rw [completedSigningRecord_forget, probCompLift_support] at ht
+  have hs : (source.1.1.1, source.1.2) ∈ support
+      ((simulateQ romImpl (signWithView key message)).run cache) := by
+    rw [← tracedSigningRun_forget (signingBoundaryTrace key.parameter), support_map]
+    exact ⟨source.1, ht, rfl⟩
+  cases hresponse : source.1.1.1.1 with
+  | none => simp [observedSigningView?, hresponse] at hview
+  | some signature =>
+      have hs' : ((some signature, source.1.1.1.2), source.1.2) ∈ support
+          ((simulateQ romImpl (signWithView key message)).run cache) := by
+        simpa only [← hresponse] using hs
+      obtain ⟨output, houtput, _, hselected⟩ :=
+        signWithView_successful_cached_output key message cache source.1.2 signature source.1.1.1.2 hs'
+      have hv : hashOutputFewTimeView output = view := by
+        simpa [observedSigningView?, hresponse, messageAnswers, houtput] using hview
+      exact (completedSigningRecord_selected_index (signingBoundaryTrace key.parameter) key message cache
+        source.1 source.2 (hashOutputFewTimeView output) hsource hselected).trans (congrArg Prod.fst hv)
+
+theorem originalProposalRecord_slots_le (key : SecretKey)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CoverLogState)
+    (hsigned : SigningDigestsCached key.parameter state.1 key.root state.2)
+    (record : ProposalExecutionRecord input) (hr : record ∈ (originalProposalRecord key input state.1).support)
+    (index : Index) :
+    (signingSlotsAtIndex (observedOptionalSigningViews (messageAnswers key.parameter record.cache)
+      key.root (state.2 ++ signingLogFragment input record.output)) index).card ≤
+        (signingSlotsAtIndex (observedOptionalSigningViews (messageAnswers key.parameter state.1)
+          key.root state.2) index).card +
+        if input matches .inr _ then (if record.index = index then 1 else 0) else 0 := by
+  have hstable := observedOptionalSigningViews_cache_stable key.parameter key.root state.1 record.cache
+    state.2 (originalProposalRecord_cache_le key input state.1 record hr) hsigned
+  cases input with
+  | inl world =>
+      change (signingSlotsAtIndex (observedOptionalSigningViews (messageAnswers key.parameter record.cache)
+        key.root (state.2 ++ [])) index).card ≤ _ + 0
+      rw [List.append_nil, hstable, Nat.add_zero]
+  | inr message =>
+      change _ ≤ _ + if record.index = index then 1 else 0
+      unfold observedOptionalSigningViews
+      change (signingSlotsAtIndex (fun slot => observedSigningView? (messageAnswers key.parameter record.cache)
+        key.root ((state.2 ++ [(⟨message, record.output⟩ : SigningEntry)]).get slot)) index).card ≤ _
+      rw [signingSlotsAtIndex_log_append_card]
+      have heq := congrArg (fun views => (signingSlotsAtIndex views index).card) hstable
+      apply Nat.add_le_add heq.le
+      split_ifs with hobserved hindex hindex
+      · exact le_rfl
+      · obtain ⟨view, hview, hsource⟩ := hobserved
+        exact False.elim (hindex ((originalProposalRecord_sign_observed_index key message state.1 record hr
+          view hview).trans hsource))
+      · exact Nat.zero_le _
+      · exact le_rfl
+
+theorem certificateProposalImpl_world_run (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule) (input : OracleWorld.Domain)
+    (state : List Index × CertificateMonitorState) :
+    (certificateProposalImpl key budget required stopAfter (.inl input)).run state =
+      (originalProposalRecord key (.inl input) state.2.1).map (fun record =>
+        (record.output, state.1, originalProposalAdvance (certificateMonitorUpdate key budget required stopAfter)
+          (.inl input) state.2 0 record)) := by
+  simp only [certificateProposalImpl, originalProposalImpl, proposalRecordImpl, originalProposalActive,
+    StateT.run_mk, Bool.false_eq_true, if_false]
+
+theorem certificateProposalImpl_sign_run (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule) (message : Message)
+    (state : List Index × CertificateMonitorState) :
+    (certificateProposalImpl key budget required stopAfter (.inr message)).run state =
+      if CertificateMonitorActive key budget (.inr message) state.2 then
+        (recordProposalBridge (originalProposalRecord key (.inr message) state.2.1)
+          (originalRejectedProposal key (fun state : CertificateMonitorState => state.2.spent) (.inr message) state.2)
+          targetProposalAcceptance targetProposalAcceptance_ne_zero targetProposalAcceptance_lt_one.le).map
+            (fun result => (result.2.output, state.1 ++ result.1 ++ [result.2.index],
+              originalProposalAdvance (certificateMonitorUpdate key budget required stopAfter)
+                (.inr message) state.2 (result.1.length + 1) result.2))
+      else (originalProposalRecord key (.inr message) state.2.1).map (fun record =>
+        (record.output, state.1, originalProposalAdvance (certificateMonitorUpdate key budget required stopAfter)
+          (.inr message) state.2 0 record)) := by
+  simp only [certificateProposalImpl, originalProposalImpl, proposalRecordImpl, StateT.run_mk,
+    certificateMonitor_sign_proposals_active, decide_eq_true_eq]
+
+structure CertificateProposalBounds (key : SecretKey) (total : Nat)
+    (state : List Index × CertificateMonitorState) : Prop where
+  log_le : state.2.2.log.length ≤ signatureLimit
+  proposals_eq : state.2.2.proposals = state.1.length
+  counts_le : ∀ index : Index,
+    (signingSlotsAtIndex (observedOptionalSigningViews (messageAnswers key.parameter state.2.1)
+      key.root state.2.2.log) index).card ≤ state.1.count index
+  prefix_le : (state.1.length : ENNReal) ≤ targetProposalOverhead * state.2.2.log.length + 131072
+  total_le : 25313293 ≤ total
+
+def CertificateProposalInvariant (key : SecretKey) (total : Nat)
+    (state : List Index × CertificateMonitorState) : Prop :=
+  state.2.2.stopped = false → CertificateProposalBounds key total state
+
+theorem certificateProposalInvariant_initial (key : SecretKey) (total spent : Nat)
+    (cache : QueryCache HashSpec) (stopped : Bool) (hpool : stopped = false → 25313293 ≤ total) :
+    CertificateProposalInvariant key total ([], cache, initialCertificateMonitor spent stopped) := by
+  intro hstopped
+  refine ⟨Nat.zero_le _, rfl, ?_, ?_, hpool hstopped⟩
+  · intro index
+    simp [initialCertificateMonitor, observedOptionalSigningViews, signingSlotsAtIndex]
+  · simp only [initialCertificateMonitor, List.length_nil, Nat.cast_zero, mul_zero, zero_add]
+    exact bot_le
+
+theorem certificateProposalInvariant_advance (key : SecretKey) (budget total : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : List Index × CertificateMonitorState)
+    (suffix : List Index) (length : Nat) (record : ProposalExecutionRecord input)
+    (hinv : CertificateProposalInvariant key total state)
+    (hactive : CertificateMonitorActive key budget input state.2)
+    (hlength : length = suffix.length)
+    (hcounts : ∀ index : Index,
+      (signingSlotsAtIndex (observedOptionalSigningViews (messageAnswers key.parameter record.cache)
+        key.root (state.2.2.log ++ signingLogFragment input record.output)) index).card ≤
+          (state.1 ++ suffix).count index) :
+    CertificateProposalInvariant key total (state.1 ++ suffix, originalProposalAdvance
+      (certificateMonitorUpdate key budget required
+        (fun input state length record => proposalPrefixStop input state length record || stopAfter input state length record))
+      input state.2 length record) := by
+  intro hpost
+  have hbefore := hinv hactive.1
+  have hstop : proposalPrefixStop input state.2 length record = false := by
+    simp only [originalProposalAdvance, certificateMonitorUpdate, if_pos hactive,
+      Bool.or_eq_false_iff] at hpost
+    exact hpost.1.1
+  have hprefix : ((state.2.2.proposals + length : Nat) : ENNReal) ≤
+      targetProposalOverhead * (state.2.2.log ++ signingLogFragment input record.output).length + 131072 := by
+    simp only [proposalPrefixStop, decide_eq_false_iff_not] at hstop
+    exact le_of_not_gt hstop
+  have hlog : (state.2.2.log ++ signingLogFragment input record.output).length ≤ signatureLimit := by
+    have hvalid := hactive.2.2.1
+    cases input with
+    | inl world => simpa only [ValidSigningStep, signingLogFragment, List.append_nil] using hvalid
+    | inr message =>
+        simpa only [signingLogFragment, List.length_append, List.length_singleton] using
+          Nat.succ_le_of_lt hvalid
+  constructor
+  · simpa only [originalProposalAdvance, certificateMonitorUpdate, if_pos hactive, proposalRecordLogState] using hlog
+  · simp only [originalProposalAdvance, certificateMonitorUpdate, if_pos hactive, List.length_append,
+      hbefore.proposals_eq, hlength]
+  · intro index
+    change (signingSlotsAtIndex (observedOptionalSigningViews (messageAnswers key.parameter record.cache)
+      key.root (certificateMonitorUpdate key budget required
+        (fun input state length record => proposalPrefixStop input state length record || stopAfter input state length record)
+        input state.2 length record).log) index).card ≤ _
+    rw [show (certificateMonitorUpdate key budget required
+        (fun input state length record => proposalPrefixStop input state length record || stopAfter input state length record)
+        input state.2 length record).log = state.2.2.log ++ signingLogFragment input record.output by
+      simp only [certificateMonitorUpdate, if_pos hactive, proposalRecordLogState]]
+    exact hcounts index
+  · simpa only [originalProposalAdvance, certificateMonitorUpdate, if_pos hactive, proposalRecordLogState,
+      List.length_append, hbefore.proposals_eq, hlength] using hprefix
+  · exact hbefore.total_le
+
+theorem certificateProposalImpl_invariant (key : SecretKey) (budget total : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : List Index × CertificateMonitorState)
+    (hinv : CertificateProposalInvariant key total state)
+    (result : (OracleWorld + SigningSpec).Range input × (List Index × CertificateMonitorState))
+    (hr : result ∈ ((certificateProposalImpl key budget required
+      (fun input state length record => proposalPrefixStop input state length record || stopAfter input state length record)
+      input).run state).support) : CertificateProposalInvariant key total result.2 := by
+  cases input with
+  | inl world =>
+      rw [certificateProposalImpl_world_run, PMF.mem_support_map_iff] at hr
+      obtain ⟨record, hrecord, rfl⟩ := hr
+      by_cases hactive : CertificateMonitorActive key budget (.inl world) state.2
+      · have hbefore := hinv hactive.1
+        have hcounts (index : Index) := originalProposalRecord_slots_le key (.inl world)
+          (certificateMonitorCoverState state.2) hactive.2.1.1 record hrecord index
+        have hafter : CertificateProposalInvariant key total (state.1 ++ [], originalProposalAdvance
+            (certificateMonitorUpdate key budget required
+              (fun input state length record => proposalPrefixStop input state length record || stopAfter input state length record))
+            (.inl world) state.2 0 record) :=
+          certificateProposalInvariant_advance key budget total required stopAfter (.inl world) state [] 0 record
+            hinv hactive rfl (fun index => by
+              have hc := hcounts index
+              change _ ≤ _ + 0 at hc
+              rw [Nat.add_zero] at hc
+              simpa only [certificateMonitorCoverState, List.append_nil] using hc.trans (hbefore.counts_le index))
+        simpa only [List.append_nil] using hafter
+      · intro hpost
+        simp only [originalProposalAdvance, certificateMonitorUpdate, if_neg hactive, Bool.true_eq_false] at hpost
+  | inr message =>
+      rw [certificateProposalImpl_sign_run] at hr
+      by_cases hactive : CertificateMonitorActive key budget (.inr message) state.2
+      · rw [if_pos hactive, PMF.mem_support_map_iff] at hr
+        obtain ⟨source, hsource, rfl⟩ := hr
+        have hrecord := (PMF.mem_support_map_iff Prod.snd _ _).mpr ⟨source, hsource, rfl⟩
+        rw [recordProposalBridge_record] at hrecord
+        have hbefore := hinv hactive.1
+        have hafter := certificateProposalInvariant_advance key budget total required stopAfter (.inr message)
+          state (source.1 ++ [source.2.index]) (source.1.length + 1) source.2 hinv hactive
+          (by simp only [List.length_append, List.length_singleton]) (fun index => by
+            have hc := originalProposalRecord_slots_le key (.inr message) (certificateMonitorCoverState state.2)
+              hactive.2.1.1 source.2 hrecord index
+            change _ ≤ _ + if source.2.index = index then 1 else 0 at hc
+            calc
+              _ ≤ _ := hc
+              _ ≤ state.1.count index + if source.2.index = index then 1 else 0 :=
+                Nat.add_le_add_right (hbefore.counts_le index) _
+              _ ≤ (state.1 ++ (source.1 ++ [source.2.index])).count index := by
+                simp only [List.count_append, List.count_cons, List.count_nil, beq_iff_eq]
+                split_ifs <;> omega)
+        simpa only [List.append_assoc] using hafter
+      · rw [if_neg hactive, PMF.mem_support_map_iff] at hr
+        obtain ⟨record, _, rfl⟩ := hr
+        intro hpost
+        simp only [originalProposalAdvance, certificateMonitorUpdate, if_neg hactive, Bool.true_eq_false] at hpost
+
+theorem certificateMonitorCharge_le_terminalPrice_of_invariant (key : SecretKey) (budget total : Nat)
+    (required : Finset FtsTree) (input : (OracleWorld + SigningSpec).Domain)
+    (state : List Index × CertificateMonitorState) (hbudget : budget ≤ 2 ^ 127)
+    (hinv : CertificateProposalInvariant key total state) :
+    certificateMonitorCharge key budget required input state.2 ≤
+      certificateMonitorMass key budget input state.2 *
+        terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice required) state.1 := by
+  by_cases hactive : CertificateMonitorActive key budget input state.2
+  · have h := hinv hactive.1
+    exact certificateMonitorCharge_le_terminalPrice key budget total required input state.2 state.1 hbudget
+      h.log_le h.counts_le h.total_le h.prefix_le
+  · simp only [certificateMonitorCharge, certificateMonitorMass, if_neg hactive, zero_mul, le_refl]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateProposalPrefixException.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateProposalPrefixException.lean
new file mode 100644
index 000000000..6559e8dd6
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateProposalPrefixException.lean
@@ -0,0 +1,23 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.ProposalPrefixStop
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp ENNReal
+attribute [local instance] Classical.propDecidable
+
+def ProposalPrefixExceptional (proposals completed : Nat) : Prop :=
+  targetProposalOverhead * completed + 131072 < (proposals : ENNReal)
+
+theorem proposalPrefixStop_eq_after_exception (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState)
+    (length : Nat) (record : ProposalExecutionRecord input)
+    (hactive : CertificateMonitorActive key budget input state) :
+    proposalPrefixStop input state length record =
+      decide (ProposalPrefixExceptional
+        (certificateMonitorUpdate key budget required stopAfter input state length record).proposals
+        (certificateMonitorUpdate key budget required stopAfter input state length record).log.length) := by
+  simp only [proposalPrefixStop, ProposalPrefixExceptional, certificateMonitorUpdate, if_pos hactive,
+    proposalRecordLogState]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateStoppedState.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateStoppedState.lean
new file mode 100644
index 000000000..9edeb6855
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateStoppedState.lean
@@ -0,0 +1,47 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CertificatePathBudget
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+
+theorem certificateMonitorUpdate_stopped (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState)
+    (length : Nat) (record : ProposalExecutionRecord input) (hstop : state.2.stopped = true) :
+    certificateMonitorUpdate key budget required stopAfter input state length record = state.2 := by
+  have hinactive : ¬ CertificateMonitorActive key budget input state := by
+    intro hactive
+    have h := hactive.1
+    rw [hstop] at h
+    exact Bool.noConfusion h
+  rw [certificateMonitorUpdate_inactive key budget required stopAfter input state length record hinactive]
+  rcases state with ⟨cache, log, spent, messageCalls, proposals, creationMass, creationCost, bank, stopped⟩
+  change stopped = true at hstop
+  subst stopped
+  rfl
+
+theorem certificateLength_run_stopped {α : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (state : CertificateMonitorState)
+    (hstop : state.2.stopped = true) (result : α × CertificateMonitorState)
+    (hr : result ∈ ((simulateQ (certificateLengthImpl key budget required stopAfter) computation).run state).support) :
+    result.2.2 = state.2 := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      simp only [simulateQ_pure, StateT.run_pure, PMF.monad_pure_eq_pure, PMF.mem_support_pure_iff] at hr
+      subst result
+      rfl
+  | query_bind input next ih =>
+      rw [simulateQ_bind, simulateQ_spec_query, StateT.run_bind, PMF.monad_bind_eq_bind,
+        PMF.mem_support_bind_iff] at hr
+      obtain ⟨middle, hmiddle, hr⟩ := hr
+      obtain ⟨length, record, _, rfl⟩ :=
+        certificateLengthImpl_support key budget required stopAfter input state middle hmiddle
+      have heq := certificateMonitorUpdate_stopped key budget required stopAfter input state length record hstop
+      have hnext : (originalProposalAdvance (certificateMonitorUpdate key budget required stopAfter)
+          input state length record).2.stopped = true := by
+        simpa only [originalProposalAdvance, heq] using hstop
+      have htail := ih record.output _ hnext result hr
+      simpa only [originalProposalAdvance, heq] using htail
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateTerminalGame.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateTerminalGame.lean
new file mode 100644
index 000000000..04cb43489
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/CertificateTerminalGame.lean
@@ -0,0 +1,98 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CertificateGame
+import SphincsSecurity.Proof.Fts.OriginalTerminalProposal
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem simulateQ_certificateProposalImpl_complete {α : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule) (total : Nat)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (state : List Index × CertificateMonitorState) :
+    ((simulateQ (certificateProposalImpl key budget required stopAfter) computation).run state).bind
+        (fun result => completeProposalWord (PMF.uniformOfFintype Index) total result.2.1) =
+      completeProposalWord (PMF.uniformOfFintype Index) total state.1 :=
+  simulateQ_originalProposalImpl_complete key (fun current : CertificateMonitorState => current.2.spent) (certificateMonitorEnabled key budget)
+    (certificateMonitorUpdate key budget required stopAfter) total computation state
+
+theorem expected_certificateProposalImpl_terminalPotential (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule) (total : Nat) (payoff : List Index → ENNReal)
+    (input : (OracleWorld + SigningSpec).Domain) (state : List Index × CertificateMonitorState) :
+    (∑' result, Pr[= result | (certificateProposalImpl key budget required stopAfter input).run state] *
+        terminalProposalPotential (PMF.uniformOfFintype Index) total payoff result.2.1) =
+      terminalProposalPotential (PMF.uniformOfFintype Index) total payoff state.1 :=
+  expected_originalProposalImpl_terminalPotential key (fun current : CertificateMonitorState => current.2.spent) (certificateMonitorEnabled key budget)
+    (certificateMonitorUpdate key budget required stopAfter) total payoff input state
+
+theorem certificateGame_complete (adversary : Adversary) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : SecretKey → CertificateStopRule) (stopped : Bool) (total : Nat) :
+    (certificateGame adversary budget required stopAfter stopped).bind
+        (fun result => completeProposalWord (PMF.uniformOfFintype Index) total result.2.1) =
+      independentProposalWord (PMF.uniformOfFintype Index) total := by
+  rw [certificateGame, PMF.monad_bind_eq_bind, PMF.bind_bind]
+  simp_rw [simulateQ_certificateProposalImpl_complete, completeProposalWord_nil]
+  exact PMF.bind_const _ _
+
+noncomputable def certificateTerminalGame (adversary : Adversary) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : SecretKey → CertificateStopRule) (stopped : Bool) (total : Nat) :
+    PMF (CertificateGameResult × List Index) :=
+  (certificateGame adversary budget required stopAfter stopped).bind fun result =>
+    (completeProposalWord (PMF.uniformOfFintype Index) total result.2.1).map (fun word => (result, word))
+
+theorem certificateTerminalGame_game (adversary : Adversary) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : SecretKey → CertificateStopRule) (stopped : Bool) (total : Nat) :
+    (certificateTerminalGame adversary budget required stopAfter stopped total).map Prod.fst =
+      certificateGame adversary budget required stopAfter stopped := by
+  rw [certificateTerminalGame, PMF.map_bind]
+  simp only [PMF.map_comp, Function.comp_def]
+  change (certificateGame adversary budget required stopAfter stopped).bind (fun result =>
+    (completeProposalWord (PMF.uniformOfFintype Index) total result.2.1).map (Function.const _ result)) = _
+  simp only [PMF.map_const, PMF.bind_pure]
+
+theorem certificateTerminalGame_word (adversary : Adversary) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : SecretKey → CertificateStopRule) (stopped : Bool) (total : Nat) :
+    (certificateTerminalGame adversary budget required stopAfter stopped total).map Prod.snd =
+      independentProposalWord (PMF.uniformOfFintype Index) total := by
+  rw [certificateTerminalGame, PMF.map_bind]
+  simp only [PMF.map_comp, Function.comp_def]
+  change (certificateGame adversary budget required stopAfter stopped).bind (fun result =>
+    (completeProposalWord (PMF.uniformOfFintype Index) total result.2.1).map id) = _
+  simp only [PMF.map_id]
+  exact certificateGame_complete adversary budget required stopAfter stopped total
+
+theorem certificateTerminalGame_cost_le (adversary : Adversary) (q : Nat) (required : Finset FtsTree)
+    (stopAfter : SecretKey → CertificateStopRule) (stopped : Bool) (total : Nat)
+    (hbound : HasHashQueryBound scheme adversary q) (result : CertificateGameResult × List Index)
+    (hr : result ∈ (certificateTerminalGame adversary q required stopAfter stopped total).support) :
+    result.1.2.2.2.spent ≤ q ∧ result.1.2.2.2.creationMass ≤ q := by
+  have hm := (PMF.mem_support_map_iff Prod.fst _ _).mpr ⟨result, hr, rfl⟩
+  rw [certificateTerminalGame_game] at hm
+  exact certificateGame_cost_le adversary q required stopAfter stopped hbound result.1 hm
+
+theorem expected_certificateTerminalGame_mass_payoff_le (adversary : Adversary) (q : Nat)
+    (required : Finset FtsTree) (stopAfter : SecretKey → CertificateStopRule) (stopped : Bool) (total : Nat)
+    (hbound : HasHashQueryBound scheme adversary q) (payoff : List Index → ENNReal) :
+    (∑' result, Pr[= result | certificateTerminalGame adversary q required stopAfter stopped total] *
+        (result.1.2.2.2.creationMass * payoff result.2)) ≤
+      (q : ENNReal) * ∑' word, Pr[= word | independentProposalWord (PMF.uniformOfFintype Index) total] * payoff word := by
+  have hword := congrArg (fun law : PMF (List Index) => ∑' word, Pr[= word | law] * payoff word)
+    (certificateTerminalGame_word adversary q required stopAfter stopped total)
+  rw [← PMF.monad_map_eq_map, tsum_probOutput_map_mul] at hword
+  calc
+    _ ≤ ∑' result, (q : ENNReal) *
+        (Pr[= result | certificateTerminalGame adversary q required stopAfter stopped total] * payoff result.2) := by
+      apply ENNReal.tsum_le_tsum
+      intro result
+      by_cases hzero : Pr[= result | certificateTerminalGame adversary q required stopAfter stopped total] = 0
+      · rw [hzero, zero_mul, zero_mul, mul_zero]
+      · have hr : result ∈ (certificateTerminalGame adversary q required stopAfter stopped total).support := by
+          simpa only [PMF.mem_support_iff, PMF.probOutput_eq_apply] using hzero
+        have hmass := (certificateTerminalGame_cost_le adversary q required stopAfter stopped total hbound result hr).2
+        calc
+          _ ≤ Pr[= result | certificateTerminalGame adversary q required stopAfter stopped total] *
+              ((q : ENNReal) * payoff result.2) := mul_le_mul' le_rfl (mul_le_mul' hmass le_rfl)
+          _ = _ := by ring
+    _ = _ := by rw [ENNReal.tsum_mul_left, hword]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/ConcreteTargetShapeQuery.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/ConcreteTargetShapeQuery.lean
new file mode 100644
index 000000000..0f99e0bab
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/ConcreteTargetShapeQuery.lean
@@ -0,0 +1,80 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.ConcreteTargetShapeSigning
+import SphincsSecurity.Proof.Fts.TargetShapeEnvelope
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem normalizedTargetLogProduct_cache_stable (key : SecretKey) (before after : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView) (remaining : Finset FtsTree)
+    (hcache : before ≤ after) (hsigned : SigningDigestsCached key.parameter before key.root log) :
+    normalizedTargetLogProduct key after log payload target remaining = normalizedTargetLogProduct key before log payload target remaining := by
+  simp only [normalizedTargetLogProduct, normalizedTargetLogMatch, eligibleSigningViews_cache_stable key before after log payload hcache hsigned]
+
+theorem expected_cacheQuery_targetShapeMoments (key : SecretKey) (before : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining)
+    (input : HashInput) (hfresh : before input = none) (hsigned : SigningDigestsCached key.parameter before key.root log)
+    (hmessage : FtsProbeSimulation.MessageHashInput key.parameter input) (hne : input ≠ tweakableHashInput key.parameter .message payload) :
+    (∑' output, Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] *
+      targetShapeMoments key (before.cacheQuery input output) log payload target groups remaining) =
+        targetShapeQuery (((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ * (Fintype.card Index : ENNReal)⁻¹)
+          (targetShapeMoments key before log payload target) groups remaining := by
+  simp only [targetShapeMoments_eq_indexed, normalizedTargetMixedMoment,
+    normalizedTargetLogProduct_cache_stable key before _ log payload target remaining (QueryCache.le_cacheQuery before hfresh) hsigned,
+    ← mul_assoc, ENNReal.tsum_mul_right]
+  rw [expected_normalizedTargetCacheProduct_cacheQuery key.parameter before _ target (targetGroupAt groups)
+    (fun slot => hvalid.nonempty _ (targetGroupAt_mem groups slot))
+    (fun i j hij => hvalid.disjoint _ (targetGroupAt_mem groups i) _ (targetGroupAt_mem groups j)
+      (fun heq => hij (targetGroupAt_injective groups heq))) input hfresh hmessage hne]
+  unfold targetShapeQuery
+  rw [targetShapeMoments_cacheLower_eq]
+  simp only [targetShapeMoments_eq_indexed, normalizedTargetMixedMoment]
+  ring
+
+theorem targetShapeMoments_cacheQuery_unchanged (key : SecretKey) (before : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (input : HashInput) (output : HashOutput)
+    (hfresh : before input = none) (hsigned : SigningDigestsCached key.parameter before key.root log)
+    (hskip : ¬ FtsProbeSimulation.MessageHashInput key.parameter input ∨ input = tweakableHashInput key.parameter .message payload) :
+    targetShapeMoments key (before.cacheQuery input output) log payload target groups remaining =
+      targetShapeMoments key before log payload target groups remaining := by
+  simp only [targetShapeMoments,
+    normalizedTargetLogProduct_cache_stable key before _ log payload target remaining (QueryCache.le_cacheQuery before hfresh) hsigned]
+  congr 1
+  apply Finset.prod_congr rfl
+  intro group _
+  rcases hskip with hmessage | rfl
+  · simp only [normalizedCachedTargetSubsetMatch, cachedTargetSubsetMatch_cacheQuery key.parameter before _ target group input output hfresh,
+      hmessage, false_and, if_false, add_zero]
+  · simp only [normalizedCachedTargetSubsetMatch, cachedTargetSubsetMatch_cacheQuery_self key.parameter before _ target group output hfresh]
+
+theorem expected_randomOracle_targetShapeMoments_le (key : SecretKey) (before : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining)
+    (input : HashInput) (hsigned : SigningDigestsCached key.parameter before key.root log) :
+    (∑' result, Pr[= result | (randomOracle input).run before] *
+      targetShapeMoments key result.2 log payload target groups remaining) ≤
+        targetShapeQuery (((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ * (Fintype.card Index : ENNReal)⁻¹)
+          (targetShapeMoments key before log payload target) groups remaining := by
+  have hmass : (∑' output, Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)]) = 1 := tsum_probOutput_eq_one' (by simp)
+  by_cases hfresh : before input = none
+  · rw [randomOracle, QueryImpl.withCaching_run_none _ hfresh, tsum_probOutput_map_mul]
+    change (∑' output, Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] *
+      targetShapeMoments key (before.cacheQuery input output) log payload target groups remaining) ≤ _
+    by_cases hmessage : FtsProbeSimulation.MessageHashInput key.parameter input
+    · by_cases heq : input = tweakableHashInput key.parameter .message payload
+      · simp only [targetShapeMoments_cacheQuery_unchanged key before log payload target groups remaining input _ hfresh hsigned (Or.inr heq),
+          ENNReal.tsum_mul_right, hmass, one_mul]
+        exact le_self_add
+      · exact (expected_cacheQuery_targetShapeMoments key before log payload target groups remaining hvalid input hfresh hsigned hmessage heq).le
+    · simp only [targetShapeMoments_cacheQuery_unchanged key before log payload target groups remaining input _ hfresh hsigned (Or.inl hmessage),
+        ENNReal.tsum_mul_right, hmass, one_mul]
+      exact le_self_add
+  · obtain ⟨output, houtput⟩ := Option.ne_none_iff_exists'.mp hfresh
+    rw [randomOracle, QueryImpl.withCaching_run_some _ houtput, tsum_probOutput_pure_mul]
+    exact le_self_add
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/ConcreteTargetShapeSigning.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/ConcreteTargetShapeSigning.lean
new file mode 100644
index 000000000..64d071c61
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/ConcreteTargetShapeSigning.lean
@@ -0,0 +1,86 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.TargetShapeOperators
+import SphincsSecurity.Proof.Fts.TargetShapeReindex
+import SphincsSecurity.Proof.Fts.NormalizedTargetCacheQuery
+import SphincsSecurity.Proof.Fts.TargetSigningMatchFactors
+
+/-! ## ClosedTargetMixedSigning -/
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def normalizedTargetMixedMoment (key : SecretKey) (cache : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView)
+    (groups : Fin m → Finset FtsTree) (required : Finset FtsTree) : ENNReal :=
+  normalizedTargetCacheProduct key.parameter cache (tweakableHashInput key.parameter .message payload) target groups *
+    normalizedTargetLogProduct key cache log payload target required
+
+end SphincsSecurity.Concrete
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def targetShapeMoments (key : SecretKey) (cache : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView) : TargetShapeVector :=
+  fun groups remaining =>
+    (∏ group ∈ groups, normalizedCachedTargetSubsetMatch key.parameter cache
+      (tweakableHashInput key.parameter .message payload) target group) *
+        normalizedTargetLogProduct key cache log payload target remaining
+
+theorem targetShapeMoments_eq_indexed (key : SecretKey) (cache : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) :
+    targetShapeMoments key cache log payload target groups remaining =
+      normalizedTargetMixedMoment key cache log payload target (targetGroupAt groups) remaining := by
+  simp only [targetShapeMoments, normalizedTargetMixedMoment, normalizedTargetCacheProduct, prod_targetGroupAt]
+
+theorem targetShapeMoments_cacheLower_eq (key : SecretKey) (cache : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) :
+    targetCacheLower (targetShapeMoments key cache log payload target) groups remaining =
+      (∑ removed ∈ (Finset.univ : Finset (Fin groups.card)).powerset.erase ∅,
+        ∏ slot ∈ (Finset.univ : Finset (Fin groups.card)) \ removed,
+          normalizedCachedTargetSubsetMatch key.parameter cache (tweakableHashInput key.parameter .message payload)
+            target (targetGroupAt groups slot)) * normalizedTargetLogProduct key cache log payload target remaining := by
+  rw [sum_targetGroupAt_removed_products, Finset.sum_mul]
+  rfl
+
+theorem targetShapeMoments_reuse_eq (key : SecretKey) (cache : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining) :
+    targetReuseStep (targetShapeMoments key cache log payload target) groups remaining =
+      (∏ group ∈ groups, normalizedCachedTargetSubsetMatch key.parameter cache
+        (tweakableHashInput key.parameter .message payload) target group) *
+          ∑ selected ∈ remaining.powerset.erase ∅,
+            normalizedCachedTargetSubsetMatch key.parameter cache (tweakableHashInput key.parameter .message payload) target selected *
+              normalizedTargetLogProduct key cache log payload target (remaining \ selected) := by
+  rw [Finset.mul_sum]
+  apply Finset.sum_congr rfl
+  intro selected hselected
+  have hnot := hvalid.new_group (Finset.nonempty_iff_ne_empty.mpr (Finset.mem_erase.mp hselected).1)
+    (Finset.mem_powerset.mp (Finset.mem_erase.mp hselected).2)
+  simp only [targetShapeMoments, Finset.prod_insert hnot]
+  ring
+
+theorem targetShapeMoments_cross_eq (key : SecretKey) (cache : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) :
+    (∑ removed ∈ (Finset.univ : Finset (Fin groups.card)).powerset.erase ∅,
+      ∑ trees ∈ remaining.powerset,
+        (∏ slot ∈ (Finset.univ : Finset (Fin groups.card)) \ removed,
+          normalizedCachedTargetSubsetMatch key.parameter cache (tweakableHashInput key.parameter .message payload)
+            target (targetGroupAt groups slot)) * normalizedTargetLogProduct key cache log payload target (remaining \ trees)) =
+      targetCacheLower (targetShapeMoments key cache log payload target) groups remaining +
+        targetCacheLower (targetTreeLower (targetShapeMoments key cache log payload target)) groups remaining := by
+  simp only [← Finset.mul_sum]
+  rw [← Finset.sum_mul, sum_targetGroupAt_removed_products, Finset.sum_mul]
+  rw [← Finset.add_sum_erase _ _ (Finset.empty_mem_powerset remaining)]
+  simp only [Finset.sdiff_empty, mul_add, Finset.mul_sum, Finset.sum_add_distrib]
+  rfl
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/DigestAttemptExpectation.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/DigestAttemptExpectation.lean
new file mode 100644
index 000000000..d2c505783
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/DigestAttemptExpectation.lean
@@ -0,0 +1,74 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FewTimeRace
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+noncomputable local instance instSampleableTypeRandomness_2 : SampleableType Randomness := SampleableType.ofFintype Randomness
+attribute [local irreducible] signAttempt signDigestAttemptPrefix
+
+abbrev DigestAttemptResult := Randomness × (Option (Index × (IndexGroup → FtsLeaf)) × QueryCache HashSpec)
+
+noncomputable def cachedDigestAttemptRate (key : SecretKey) (message : Message)
+    (cache : QueryCache HashSpec) (P : FewTimeView → Prop) : ENNReal :=
+  Pr[fun randomness : Randomness => ∃ output,
+    cache (tweakableHashInput key.parameter .message (messageDigestPayload key.root message randomness)) = some output ∧
+      signAttemptResultOfOutput output ≠ none ∧ P (hashOutputFewTimeView output) | ($ᵗ Randomness : ProbComp Randomness)]
+
+noncomputable def digestAttemptExpectation : Nat → SecretKey → Message → QueryCache HashSpec → ENNReal
+  | 0, _, _, _ => 0
+  | attempts + 1, key, message, cache => 1 +
+      ∑' result, Pr[= result | signDigestAttemptPrefix key message cache] *
+        if result.2.1 = none then digestAttemptExpectation attempts key message result.2.2 else 0
+
+theorem signDigestAttemptPrefix_support_attempt (key : SecretKey) (message : Message)
+    (cache : QueryCache HashSpec) (result : DigestAttemptResult)
+    (hr : result ∈ support (signDigestAttemptPrefix key message cache)) :
+    result.2 ∈ support ((simulateQ (randomOracle : QueryImpl HashSpec _)
+      (signAttempt key message result.1)).run cache) := by
+  rw [signDigestAttemptPrefix, mem_support_bind_iff] at hr
+  obtain ⟨randomness, _, hr⟩ := hr
+  rw [mem_support_bind_iff] at hr
+  obtain ⟨attempt, ha, hr⟩ := hr
+  simp only [mem_support_pure_iff] at hr
+  have hfirst := congrArg Prod.fst hr
+  have hsecond := congrArg Prod.snd hr
+  rw [hfirst, hsecond]
+  exact ha
+
+theorem signDigestAttemptPrefix_cache_le (key : SecretKey) (message : Message)
+    (cache : QueryCache HashSpec) (result : DigestAttemptResult)
+    (hr : result ∈ support (signDigestAttemptPrefix key message cache)) : cache ≤ result.2.2 := by
+  apply simulateQ_romImpl_cache_le (liftM (signAttempt key message result.1 :
+    OracleComp HashSpec (Option (Index × (IndexGroup → FtsLeaf))))) cache result.2
+  rw [simulateQ_romImpl_liftM]
+  exact signDigestAttemptPrefix_support_attempt key message cache result hr
+
+theorem signDigestAttemptPrefix_cached_result (key : SecretKey) (message : Message)
+    (cache : QueryCache HashSpec) (result : DigestAttemptResult) (output : HashOutput)
+    (hr : result ∈ support (signDigestAttemptPrefix key message cache))
+    (hc : cache (tweakableHashInput key.parameter .message (messageDigestPayload key.root message result.1)) = some output) :
+    result.2.1 = signAttemptResultOfOutput output :=
+  signAttempt_result_of_cached key message result.1 cache result.2.2 result.2.1 output
+    ((signDigestAttemptPrefix_cache_le key message cache result hr) hc)
+    (signDigestAttemptPrefix_support_attempt key message cache result hr)
+
+theorem probEvent_signDigestAttemptPrefix_favorablePrehit_eq
+    (referenceCache workingCache : QueryCache HashSpec) (key : SecretKey) (message : Message) (P : FewTimeView → Prop) :
+    Pr[FavorablePrehitAttempt referenceCache key message P | signDigestAttemptPrefix key message workingCache] =
+      cachedDigestAttemptRate key message referenceCache P := by
+  rw [signDigestAttemptPrefix, probEvent_bind_eq_tsum, cachedDigestAttemptRate, probEvent_eq_tsum_ite]
+  apply tsum_congr
+  intro randomness
+  rw [show (fun result => pure (randomness, result)) = pure ∘ fun result => (randomness, result) from rfl,
+    probEvent_bind_pure_comp]
+  change Pr[= randomness | ($ᵗ Randomness : ProbComp Randomness)] *
+    Pr[fun _ => ∃ output, referenceCache (tweakableHashInput key.parameter .message
+      (messageDigestPayload key.root message randomness)) = some output ∧ signAttemptResultOfOutput output ≠ none ∧
+        P (hashOutputFewTimeView output) |
+      (simulateQ (randomOracle : QueryImpl HashSpec _) (signAttempt key message randomness)).run workingCache] = _
+  rw [probEvent_const]
+  rw [probFailure_of_liftM_PMF, tsub_zero]
+  split_ifs <;> simp only [mul_one, mul_zero]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/DigestCompletionBank.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/DigestCompletionBank.lean
new file mode 100644
index 000000000..9d9ffdfe0
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/DigestCompletionBank.lean
@@ -0,0 +1,93 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.BankedTargetEnvelope
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] signDigestLoop
+
+theorem expected_digestCompletion_reuseTarget_le {α : Type}
+    (key : SecretKey) (reuse : ENNReal) (budget : Nat) (payload : HashInput) (target : FewTimeView)
+    (signatures : Nat) (state : CoverLogState) (message : Message)
+    (finish : DigestLoopRecord → ProbComp α)
+    (record : α → (Option Signature × Option FewTimeView) × QueryCache HashSpec)
+    (hcompletion : ∀ loop ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run state.1),
+      ∀ result ∈ support (finish loop), DigestCompletionPreservesMessages key loop (record result))
+    (hsigned : SigningDigestsCached key.parameter state.1 key.root state.2)
+    (hreuse : exactDigestReuseWeight key message state.1 ≤ reuse)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining) :
+    (∑' result, Pr[= result | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run state.1 >>= finish] *
+      reuseTargetEnvelope key reuse budget payload target signatures
+        ((record result).2, state.2 ++ [⟨message, (record result).1.1⟩]) groups remaining) ≤
+      reuseTargetEnvelope key reuse budget payload target (signatures + 1) state groups remaining := by
+  unfold reuseTargetEnvelope
+  rw [targetShapeEnvelope_expected]
+  exact (targetShapeEnvelope_mono _ _ _ budget signatures
+    (fun G R hv => expected_digestCompletion_targetShapeMoments_le_of_exactReuse key message state.1 finish record hcompletion
+      state.2 payload target G R hv hsigned reuse hreuse) groups remaining hvalid).trans
+        (targetShapeEnvelope_signing_le _ _ _ budget signatures _ groups remaining hvalid)
+
+theorem expected_digestCompletion_reuseNewTarget_le_mass_mul {α : Type}
+    (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat) (state : CoverLogState) (message : Message)
+    (finish : DigestLoopRecord → ProbComp α)
+    (record : α → (Option Signature × Option FewTimeView) × QueryCache HashSpec)
+    (hcompletion : ∀ loop ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run state.1),
+      ∀ result ∈ support (finish loop), DigestCompletionPreservesMessages key loop (record result))
+    (hsigned : SigningDigestsCached key.parameter state.1 key.root state.2)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining) :
+    (∑' result, Pr[= result | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run state.1 >>= finish] *
+      reuseNewTargetEnvelope key reuse budget signatures state.1
+        ((record result).2, state.2 ++ [⟨message, (record result).1.1⟩]) groups remaining) ≤
+      freshDigestSelectionProbability key message state.1 *
+        ((Fintype.card Index : ENNReal)⁻¹ * reuseRawEnvelope key reuse budget signatures state groups remaining) := by
+  have h := expected_digestCompletion_newTargetEnvelopeCharge_le_mass_mul key message state.1 finish record hcompletion
+    state.2 hsigned (Fintype.card Index : ENNReal)⁻¹ reuse
+    (((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ * (Fintype.card Index : ENNReal)⁻¹) budget signatures groups remaining hvalid
+  refine h.trans_eq ?_
+  unfold reuseRawEnvelope observedRawIndexShapeVector
+  rw [targetShapeEnvelope_lift _ _ _ _ _ _ groups remaining hvalid]
+
+theorem expected_digestCompletion_bankedTarget_le {α : Type}
+    (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat) (required : Finset FtsTree)
+    (state : CoverLogState) (bank : HashInput → Bool) (message : Message)
+    (finish : DigestLoopRecord → ProbComp α)
+    (record : α → (Option Signature × Option FewTimeView) × QueryCache HashSpec)
+    (hcompletion : ∀ loop ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run state.1),
+      ∀ result ∈ support (finish loop), DigestCompletionPreservesMessages key loop (record result))
+    (stopped : α → Bool)
+    (hsigned : SigningDigestsCached key.parameter state.1 key.root state.2)
+    (hreuse : exactDigestReuseWeight key message state.1 ≤ reuse) :
+    (∑' result, Pr[= result | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run state.1 >>= finish] *
+      bankedTargetEnvelope key reuse budget signatures required
+        ((record result).2, state.2 ++ [⟨message, (record result).1.1⟩])
+        (completedTargetBank key required ((record result).2, state.2 ++ [⟨message, (record result).1.1⟩]) bank) (stopped result)) ≤
+      bankedTargetEnvelope key reuse budget (signatures + 1) required state bank false +
+        freshDigestSelectionProbability key message state.1 *
+          ((Fintype.card Index : ENNReal)⁻¹ * reuseRawEnvelope key reuse budget signatures state ∅ required) *
+            targetCertificateScale required := by
+  have hvalid : TargetShapeValid ∅ required := by constructor <;> simp
+  apply expected_bankedCacheWeight_step_le_of_split
+  · intro result hr value
+    rw [mem_support_bind_iff] at hr
+    obtain ⟨loop, hl, hf⟩ := hr
+    have hmessages := (hcompletion loop hl result hf).2
+    rw [cacheMessageWeight_messageAnswers_congr key.parameter (record result).2 loop.2 hmessages value,
+      cacheMessageWeight_messageAnswers_congr key.parameter (record result).2 loop.2 hmessages
+        (fun input target => if state.1 input = none then value input target else 0)]
+    exact cacheMessageWeight_of_le key.parameter value state.1 loop.2
+      (simulateQ_romImpl_cache_le (signDigestLoop digestAttemptLimit key message) state.1 loop hl)
+  · intro result _ query hcertificate
+    exact one_le_targetCertificateEntry_of_certificate key reuse budget signatures required _ query
+      (of_decide_eq_true hcertificate)
+  · intro query target
+    simp only [targetCertificateForecast, ← mul_assoc, ENNReal.tsum_mul_right]
+    exact mul_le_mul' (expected_digestCompletion_reuseTarget_le key reuse budget (payloadOf query) target
+      signatures state message finish record hcompletion hsigned hreuse ∅ required hvalid) le_rfl
+  · have h := expected_digestCompletion_reuseNewTarget_le_mass_mul key reuse budget signatures state message finish record hcompletion
+      hsigned ∅ required hvalid
+    have hforecast (result : α) := newTargetCertificateForecast_eq key reuse budget signatures required state.1
+      ((record result).2, state.2 ++ [⟨message, (record result).1.1⟩])
+    simpa only [hforecast, ← mul_assoc, ENNReal.tsum_mul_right] using
+      mul_le_mul' h (le_refl (targetCertificateScale required))
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/DigestCompletionCacheGrowth.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/DigestCompletionCacheGrowth.lean
new file mode 100644
index 000000000..07eca07a5
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/DigestCompletionCacheGrowth.lean
@@ -0,0 +1,209 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.DigestCompletionLogGrowth
+import SphincsSecurity.Proof.Fts.SingleMessageCacheGrowth
+
+/-! ## SignerNewMessageUnique -/
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+set_option backward.isDefEq.respectTransparency false
+
+theorem signDigestLoop_new_payload_eq_selected (attempts : Nat) (key : SecretKey) (message : Message)
+    (before after : QueryCache HashSpec) (randomness : Randomness) (index : Index) (leaves : IndexGroup → FtsLeaf)
+    (hloop : (some (randomness, index, leaves), after) ∈ support ((simulateQ romImpl (signDigestLoop attempts key message)).run before))
+    (payload : HashInput) (output : HashOutput)
+    (hbefore : before (tweakableHashInput key.parameter .message payload) = none)
+    (hafter : after (tweakableHashInput key.parameter .message payload) = some output)
+    (hadmissible : Admissible (truncateMessageDigest output)) :
+    payload = messageDigestPayload key.root message randomness := by
+  obtain ⟨selected, selectedIndex, selectedLeaves, hselected, hpayload⟩ := signDigestLoop_new_admissible_selected attempts key message
+    before after (some (randomness, index, leaves)) hloop payload output hbefore hafter hadmissible
+  have hrandomness : randomness = selected := congrArg Prod.fst (Option.some.inj hselected)
+  exact hpayload.trans (congrArg _ hrandomness.symm)
+
+end SphincsSecurity.Concrete
+
+/-! ## TargetSigningCacheGrowth -/
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (messageAnswers MessageHashInput)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def targetMixedSigningGrowth (key : SecretKey) (before after : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView)
+    (groups : Fin m → Finset FtsTree) (required : Finset FtsTree) : ENNReal :=
+  (normalizedTargetCacheProduct key.parameter after (tweakableHashInput key.parameter .message payload) target groups -
+    normalizedTargetCacheProduct key.parameter before (tweakableHashInput key.parameter .message payload) target groups) *
+      normalizedTargetLogProduct key after log payload target required
+
+noncomputable def newTargetMixedGrowthWeight (key : SecretKey) (before : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView)
+    (groups : Fin m → Finset FtsTree) (required : Finset FtsTree) (source : FewTimeView) : ENNReal :=
+  targetMixedGrowthPolynomial
+    (fun slot => normalizedCachedTargetSubsetMatch key.parameter before (tweakableHashInput key.parameter .message payload) target (groups slot))
+    (normalizedTargetLogMatch key before log payload target) groups required target source
+
+end SphincsSecurity.Concrete
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (messageAnswers MessageHashInput)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] signDigestLoop
+
+theorem signDigestLoop_cacheMessageWeight_eq (key : SecretKey) (message : Message) (before : QueryCache HashSpec)
+    (loop : DigestLoopRecord)
+    (hloop : loop ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before))
+    (weight : HashInput → FewTimeView → ENNReal) :
+    cacheMessageWeight key.parameter weight loop.2 = cacheMessageWeight key.parameter weight before +
+      selectedLoopInputWeight key message (fun input source => if before input = none then weight input source else 0) loop := by
+  have hcache := simulateQ_romImpl_cache_le (signDigestLoop digestAttemptLimit key message) before loop hloop
+  obtain ⟨selected, after⟩ := loop
+  cases selected with
+  | none =>
+      simp only [selectedLoopInputWeight, add_zero]
+      apply cacheMessageWeight_of_no_new key.parameter weight before after hcache
+      intro input output hfresh hmessage hafter hadmissible
+      obtain ⟨payload, rfl⟩ := hmessage
+      obtain ⟨_, _, _, hselected, _⟩ := signDigestLoop_new_admissible_selected digestAttemptLimit key message
+        before after none hloop payload output hfresh hafter hadmissible
+      contradiction
+  | some selected =>
+      obtain ⟨randomness, index, leaves⟩ := selected
+      by_cases hfresh : before (tweakableHashInput key.parameter .message (messageDigestPayload key.root message randomness)) = none
+      · obtain ⟨output, houtput, hadmissible, hview⟩ := signDigestLoop_selected_cached_output digestAttemptLimit key message
+          before after randomness index leaves hloop
+        simp only [selectedLoopInputWeight, hfresh, if_true]
+        rw [← hview]
+        apply cacheMessageWeight_of_single_new key.parameter weight before after hcache _ output hfresh
+          ⟨messageDigestPayload key.root message randomness, rfl⟩ houtput hadmissible
+        intro other answer hbefore hmessage hafter hgood
+        obtain ⟨payload, rfl⟩ := hmessage
+        exact congrArg (tweakableHashInput key.parameter .message)
+          (signDigestLoop_new_payload_eq_selected digestAttemptLimit key message before after randomness index leaves hloop
+            payload answer hbefore hafter hgood)
+      · simp only [selectedLoopInputWeight, if_neg hfresh, add_zero]
+        apply cacheMessageWeight_of_no_new key.parameter weight before after hcache
+        intro input output hbefore hmessage hafter hadmissible
+        obtain ⟨payload, rfl⟩ := hmessage
+        have hpayload := signDigestLoop_new_payload_eq_selected digestAttemptLimit key message before after
+          randomness index leaves hloop payload output hbefore hafter hadmissible
+        exact hfresh (hpayload ▸ hbefore)
+
+theorem digestCompletion_cacheMessageWeight_eq (key : SecretKey) (message : Message) (before : QueryCache HashSpec)
+    (loop : DigestLoopRecord)
+    (hloop : loop ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before))
+    (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec)
+    (hcompletion : DigestCompletionPreservesMessages key loop result) (weight : HashInput → FewTimeView → ENNReal) :
+    cacheMessageWeight key.parameter weight result.2 = cacheMessageWeight key.parameter weight before +
+      selectedLoopInputWeight key message (fun input source => if before input = none then weight input source else 0) loop := by
+  rw [cacheMessageWeight_messageAnswers_congr key.parameter result.2 loop.2 hcompletion.2]
+  exact signDigestLoop_cacheMessageWeight_eq key message before loop hloop weight
+
+theorem digestCompletion_targetCacheProduct_le_of_fresh (key : SecretKey) (message : Message) (before : QueryCache HashSpec)
+    (loop : DigestLoopRecord)
+    (hloop : loop ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before))
+    (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec)
+    (hcompletion : DigestCompletionPreservesMessages key loop result)
+    (randomness : Randomness) (index : Index) (leaves : IndexGroup → FtsLeaf)
+    (hselected : loop.1 = some (randomness, index, leaves))
+    (hfresh : before (tweakableHashInput key.parameter .message (messageDigestPayload key.root message randomness)) = none)
+    (targetInput : HashInput) (target : FewTimeView) (groups : Fin m → Finset FtsTree) :
+    normalizedTargetCacheProduct key.parameter result.2 targetInput target groups ≤
+      normalizedTargetCacheProduct key.parameter before targetInput target groups +
+        targetCacheArrivalPolynomial (fun slot => normalizedCachedTargetSubsetMatch key.parameter before targetInput target (groups slot))
+          groups target (selectedFewTimeView index leaves) := by
+  unfold normalizedTargetCacheProduct
+  rw [targetCacheProduct_add_arrival]
+  apply Finset.prod_le_prod'
+  intro slot _
+  simp only [normalizedCachedTargetSubsetMatch_eq_weight]
+  rw [digestCompletion_cacheMessageWeight_eq key message before loop hloop result hcompletion]
+  simp only [selectedLoopInputWeight, hselected, hfresh, if_true]
+  apply add_le_add le_rfl
+  split_ifs; exact bot_le; exact le_rfl
+
+theorem digestCompletion_targetLogProduct_le_view (key : SecretKey) (message : Message) (before : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView) (required : Finset FtsTree)
+    (hsigned : SigningDigestsCached key.parameter before key.root log)
+    (loop : DigestLoopRecord)
+    (hloop : loop ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before))
+    (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec)
+    (hcompletion : DigestCompletionPreservesMessages key loop result)
+    (randomness : Randomness) (index : Index) (leaves : IndexGroup → FtsLeaf)
+    (hselected : loop.1 = some (randomness, index, leaves)) :
+    normalizedTargetLogProduct key result.2 (log ++ [⟨message, result.1.1⟩]) payload target required ≤
+      ∏ tree ∈ required, (normalizedTargetLogMatch key before log payload target tree +
+        normalizedSourceSubsetMatch target (selectedFewTimeView index leaves) {tree}) := by
+  let weight := fun input source => if input = tweakableHashInput key.parameter .message payload then 0
+    else normalizedTargetLogIncrement key before log payload target required source
+  calc
+    _ ≤ normalizedTargetLogProduct key before log payload target required +
+        successfulSignerInputWeight key message weight result :=
+      digestCompletion_normalizedTargetLogProduct_le_input key message before log payload target required hsigned loop hloop result hcompletion
+    _ ≤ normalizedTargetLogProduct key before log payload target required + selectedLoopInputWeight key message weight loop :=
+      add_le_add le_rfl (successfulSignerInputWeight_le_selectedLoopInputWeight key message weight loop result hcompletion.1)
+    _ ≤ normalizedTargetLogProduct key before log payload target required +
+        normalizedTargetLogIncrement key before log payload target required (selectedFewTimeView index leaves) := by
+      apply add_le_add le_rfl
+      simp only [selectedLoopInputWeight, hselected, weight]
+      split_ifs; exact bot_le; exact le_rfl
+    _ = _ := normalizedTargetLogProduct_add_increment key before log payload target required (selectedFewTimeView index leaves)
+
+theorem digestCompletion_targetMixedGrowth_le_freshInput (key : SecretKey) (message : Message) (before : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView) (groups : Fin m → Finset FtsTree) (required : Finset FtsTree)
+    (hsigned : SigningDigestsCached key.parameter before key.root log)
+    (loop : DigestLoopRecord)
+    (hloop : loop ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before))
+    (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec)
+    (hcompletion : DigestCompletionPreservesMessages key loop result) :
+    targetMixedSigningGrowth key before result.2 (log ++ [⟨message, result.1.1⟩]) payload target groups required ≤
+      selectedLoopInputWeight key message (fun input source => if before input = none then
+        newTargetMixedGrowthWeight key before log payload target groups required source else 0) loop := by
+  by_cases hnew : ∃ randomness index leaves, loop.1 = some (randomness, index, leaves) ∧
+      before (tweakableHashInput key.parameter .message (messageDigestPayload key.root message randomness)) = none
+  · obtain ⟨randomness, index, leaves, hselected, hfresh⟩ := hnew
+    have hproduct := digestCompletion_targetCacheProduct_le_of_fresh key message before loop hloop result hcompletion
+      randomness index leaves hselected hfresh (tweakableHashInput key.parameter .message payload) target groups
+    have hlog := digestCompletion_targetLogProduct_le_view key message before log payload target required hsigned loop hloop result hcompletion
+      randomness index leaves hselected
+    simp only [selectedLoopInputWeight, hselected, hfresh, if_true]
+    exact mul_le_mul' (tsub_le_iff_right.mpr (hproduct.trans_eq (add_comm _ _))) hlog
+  · have hzero (weight : HashInput → FewTimeView → ENNReal) : selectedLoopInputWeight key message
+        (fun input source => if before input = none then weight input source else 0) loop = 0 := by
+      cases hs : loop.1 with
+      | none => simp only [selectedLoopInputWeight, hs]
+      | some selected =>
+          obtain ⟨randomness, index, leaves⟩ := selected
+          have hfresh : before (tweakableHashInput key.parameter .message (messageDigestPayload key.root message randomness)) ≠ none :=
+            fun hc => hnew ⟨randomness, index, leaves, hs, hc⟩
+          simp only [selectedLoopInputWeight, hs, if_neg hfresh]
+    have hcounts (slot : Fin m) : normalizedCachedTargetSubsetMatch key.parameter result.2
+        (tweakableHashInput key.parameter .message payload) target (groups slot) =
+        normalizedCachedTargetSubsetMatch key.parameter before (tweakableHashInput key.parameter .message payload) target (groups slot) := by
+      simp only [normalizedCachedTargetSubsetMatch_eq_weight]
+      rw [digestCompletion_cacheMessageWeight_eq key message before loop hloop result hcompletion, hzero, add_zero]
+    simp only [targetMixedSigningGrowth, normalizedTargetCacheProduct, hcounts, tsub_self, zero_mul, zero_le]
+
+theorem expected_digestCompletion_targetMixedGrowth_le_freshMass {α : Type}
+    (key : SecretKey) (message : Message) (before : QueryCache HashSpec)
+    (finish : DigestLoopRecord → ProbComp α)
+    (record : α → (Option Signature × Option FewTimeView) × QueryCache HashSpec)
+    (hcompletion : ∀ loop ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before),
+      ∀ result ∈ support (finish loop), DigestCompletionPreservesMessages key loop (record result))
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView) (groups : Fin m → Finset FtsTree) (required : Finset FtsTree)
+    (hsigned : SigningDigestsCached key.parameter before key.root log) :
+    (∑' result, Pr[= result | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before >>= finish] *
+      targetMixedSigningGrowth key before (record result).2 (log ++ [⟨message, (record result).1.1⟩]) payload target groups required) ≤
+      freshDigestSelectionProbability key message before *
+        ∑' source, Pr[= source | ($ᵗ FewTimeView : ProbComp FewTimeView)] * newTargetMixedGrowthWeight key before log payload target groups required source :=
+  expected_digestCompletion_freshCost_le key message before finish _ _ (fun loop hl result hr =>
+    digestCompletion_targetMixedGrowth_le_freshInput key message before log payload target groups required hsigned
+      loop hl (record result) (hcompletion loop hl result hr))
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/DigestCompletionLogGrowth.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/DigestCompletionLogGrowth.lean
new file mode 100644
index 000000000..62dba3087
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/DigestCompletionLogGrowth.lean
@@ -0,0 +1,104 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.DigestSigningCompletion
+import SphincsSecurity.Proof.Fts.NormalizedTargetLogSigning
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (messageAnswers)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] signDigestLoop
+
+theorem digestCompletion_normalizedTargetLogProduct_le_input
+    (key : SecretKey) (message : Message) (before : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView) (required : Finset FtsTree)
+    (hsigned : SigningDigestsCached key.parameter before key.root log)
+    (loop : DigestLoopRecord)
+    (hloop : loop ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before))
+    (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec)
+    (hcompletion : DigestCompletionPreservesMessages key loop result) :
+    normalizedTargetLogProduct key result.2 (log ++ [⟨message, result.1.1⟩]) payload target required ≤
+      normalizedTargetLogProduct key before log payload target required +
+        successfulSignerInputWeight key message (fun input source =>
+          if input = tweakableHashInput key.parameter .message payload then 0
+          else normalizedTargetLogIncrement key before log payload target required source) result := by
+  have hcache := simulateQ_romImpl_cache_le (signDigestLoop digestAttemptLimit key message) before loop hloop
+  have hproject : normalizedTargetLogProduct key result.2 (log ++ [⟨message, result.1.1⟩]) payload target required =
+      normalizedTargetLogProduct key loop.2 (log ++ [⟨message, result.1.1⟩]) payload target required := by
+    unfold normalizedTargetLogProduct normalizedTargetLogMatch
+    rw [hcompletion.2]
+  rw [hproject]
+  cases hs : result.1.1 with
+  | none =>
+      rw [normalizedTargetLogProduct_append_none key before loop.2 log _ payload target required hcache hsigned
+        (by simp [eligibleSigningView?])]
+      simp only [successfulSignerInputWeight, hs, add_zero, le_refl]
+  | some signature =>
+      obtain ⟨output, houtput, _, hview⟩ := digestCompletion_successful_cached_output key message before loop hloop result hcompletion signature hs
+      have hcached : loop.2 (tweakableHashInput key.parameter .message
+          (messageDigestPayload key.root message signature.randomness)) = some output :=
+        (congrFun hcompletion.2 (messageDigestPayload key.root message signature.randomness)).symm.trans houtput
+      by_cases hsame : messageDigestPayload key.root message signature.randomness = payload
+      · rw [normalizedTargetLogProduct_append_none key before loop.2 log _ payload target required hcache hsigned
+          (by simp [eligibleSigningView?, hsame])]
+        exact le_self_add
+      · have hinput : tweakableHashInput key.parameter .message (messageDigestPayload key.root message signature.randomness) ≠
+            tweakableHashInput key.parameter .message payload := by
+          intro heq
+          exact hsame (tweakableHashInput_injective key.parameter (by trivial) (by trivial) heq).2
+        simp only [successfulSignerInputWeight, hs, hview, if_neg hinput]
+        rw [normalizedTargetLogProduct_add_increment]
+        apply Finset.prod_le_prod'
+        intro tree _
+        exact normalizedTargetLogMatch_le_of_eligibleView key before loop.2 log ⟨message, some signature⟩ payload target
+          (hashOutputFewTimeView output) tree hcache hsigned (Or.inr (by
+            simp [eligibleSigningView?, observedSigningView?, messageAnswers, hsame, hcached]))
+
+theorem expected_digestCompletion_normalizedTargetLogProduct_le_of_exactReuse {α : Type}
+    (key : SecretKey) (message : Message) (before : QueryCache HashSpec)
+    (finish : DigestLoopRecord → ProbComp α)
+    (record : α → (Option Signature × Option FewTimeView) × QueryCache HashSpec)
+    (hcompletion : ∀ loop ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before),
+      ∀ result ∈ support (finish loop), DigestCompletionPreservesMessages key loop (record result))
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView) (required : Finset FtsTree)
+    (hsigned : SigningDigestsCached key.parameter before key.root log)
+    (reuse : ENNReal) (hreuse : exactDigestReuseWeight key message before ≤ reuse) :
+    (∑' result, Pr[= result | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before >>= finish] *
+      normalizedTargetLogProduct key (record result).2 (log ++ [⟨message, (record result).1.1⟩]) payload target required) ≤
+      normalizedTargetLogProduct key before log payload target required +
+        (Fintype.card Index : ENNReal)⁻¹ *
+          (∑ selected ∈ required.powerset.erase ∅, normalizedTargetLogProduct key before log payload target (required \ selected)) +
+        (∑ selected ∈ required.powerset.erase ∅,
+          normalizedCachedTargetSubsetMatch key.parameter before (tweakableHashInput key.parameter .message payload) target selected *
+            normalizedTargetLogProduct key before log payload target (required \ selected)) * reuse := by
+  let computation := (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before >>= finish
+  let weight := fun input source => if input = tweakableHashInput key.parameter .message payload then 0
+    else normalizedTargetLogIncrement key before log payload target required source
+  have hweight (input : HashInput) (source : FewTimeView) :
+      weight input source ≤ normalizedTargetLogIncrement key before log payload target required source := by
+    unfold weight
+    split_ifs; exact bot_le; exact le_rfl
+  calc
+    _ ≤ ∑' result, Pr[= result | computation] *
+        (normalizedTargetLogProduct key before log payload target required + successfulSignerInputWeight key message weight (record result)) := by
+      apply ENNReal.tsum_le_tsum
+      intro result
+      by_cases hr : result ∈ support computation
+      · change result ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before >>= finish) at hr
+        rw [mem_support_bind_iff] at hr
+        obtain ⟨loop, hl, hf⟩ := hr
+        exact mul_le_mul' le_rfl (digestCompletion_normalizedTargetLogProduct_le_input key message before log payload target required
+          hsigned loop hl (record result) (hcompletion loop hl result hf))
+      · rw [probOutput_eq_zero_of_not_mem_support hr, zero_mul, zero_mul]
+    _ ≤ normalizedTargetLogProduct key before log payload target required +
+        ∑' result, Pr[= result | computation] * successfulSignerInputWeight key message weight (record result) := by
+      simp only [mul_add, ENNReal.tsum_add, ENNReal.tsum_mul_right]
+      exact add_le_add (mul_le_of_le_one_left' tsum_probOutput_le_one) le_rfl
+    _ ≤ _ := by
+      have hbound := (expected_digestCompletion_successfulInputWeight_le_allMessage key message before finish record
+        (fun loop hl result hr => (hcompletion loop hl result hr).1) weight _ hweight reuse hreuse).trans
+          (add_le_add (mul_le_of_le_one_left' (freshDigestSelectionProbability_le_one key message before)) le_rfl)
+      simp only [weight, expected_normalizedTargetLogIncrement, cached_normalizedTargetLogIncrement] at hbound
+      simpa only [add_assoc, computation, weight] using add_le_add
+        (le_refl (normalizedTargetLogProduct key before log payload target required)) hbound
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/DigestCompletionNewTarget.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/DigestCompletionNewTarget.lean
new file mode 100644
index 000000000..8b1a72356
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/DigestCompletionNewTarget.lean
@@ -0,0 +1,124 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.DigestCompletionCacheGrowth
+import SphincsSecurity.Proof.Fts.FreshTargetEnvelope
+import SphincsSecurity.Proof.Fts.FreshTargetPayload
+import SphincsSecurity.Proof.Fts.NewTargetEnvelopeCharge
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (messageAnswers)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] signDigestLoop
+
+theorem digestCompletion_new_targetShapeMoments_eq (key : SecretKey) (message : Message) (before : QueryCache HashSpec)
+    (loop : DigestLoopRecord)
+    (hloop : loop ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before))
+    (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec)
+    (hcompletion : DigestCompletionPreservesMessages key loop result)
+    (log : QueryLog SigningSpec) (hsigned : SigningDigestsCached key.parameter before key.root log)
+    (randomness : Randomness) (index : Index) (leaves : IndexGroup → FtsLeaf)
+    (hselected : loop.1 = some (randomness, index, leaves))
+    (hfresh : before (tweakableHashInput key.parameter .message (messageDigestPayload key.root message randomness)) = none)
+    (target : FewTimeView) :
+    targetShapeMoments key result.2 (log ++ [⟨message, result.1.1⟩]) (messageDigestPayload key.root message randomness) target =
+      targetShapeMoments key before log (messageDigestPayload key.root message randomness) target := by
+  have hcache := simulateQ_romImpl_cache_le (signDigestLoop digestAttemptLimit key message) before loop hloop
+  have heligible : eligibleSigningView? (messageAnswers key.parameter loop.2) key.root
+      (messageDigestPayload key.root message randomness) ⟨message, result.1.1⟩ = none := by
+    cases hs : result.1.1 with
+    | none => simp [eligibleSigningView?]
+    | some signature =>
+        obtain ⟨otherIndex, otherLeaves, hother⟩ := hcompletion.1.2 signature hs
+        have hr : signature.randomness = randomness := congrArg Prod.fst (Option.some.inj (hother.symm.trans hselected))
+        simp [eligibleSigningView?, hr]
+  have hlog (required : Finset FtsTree) :
+      normalizedTargetLogProduct key result.2 (log ++ [⟨message, result.1.1⟩]) (messageDigestPayload key.root message randomness) target required =
+        normalizedTargetLogProduct key before log (messageDigestPayload key.root message randomness) target required := by
+    have heq : normalizedTargetLogProduct key result.2 (log ++ [⟨message, result.1.1⟩])
+        (messageDigestPayload key.root message randomness) target required =
+      normalizedTargetLogProduct key loop.2 (log ++ [⟨message, result.1.1⟩])
+        (messageDigestPayload key.root message randomness) target required := by
+      unfold normalizedTargetLogProduct normalizedTargetLogMatch
+      rw [hcompletion.2]
+    rw [heq]
+    exact normalizedTargetLogProduct_append_none key before loop.2 log _ _ target required hcache hsigned heligible
+  funext groups remaining
+  unfold targetShapeMoments
+  rw [hlog]
+  congr 1
+  apply Finset.prod_congr rfl
+  intro group _
+  simp only [normalizedCachedTargetSubsetMatch_eq_weight]
+  rw [digestCompletion_cacheMessageWeight_eq key message before loop hloop result hcompletion]
+  simp only [selectedLoopInputWeight, hselected, hfresh, if_true, add_zero]
+
+theorem digestCompletion_newTargetEnvelopeCharge_eq_selected
+    (key : SecretKey) (message : Message) (before : QueryCache HashSpec)
+    (loop : DigestLoopRecord)
+    (hloop : loop ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before))
+    (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec)
+    (hcompletion : DigestCompletionPreservesMessages key loop result)
+    (log : QueryLog SigningSpec) (hsigned : SigningDigestsCached key.parameter before key.root log)
+    (uniform reuse arrival : ENNReal) (queries signings : Nat)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) :
+    newTargetEnvelopeCharge key before result.2 (log ++ [⟨message, result.1.1⟩]) uniform reuse arrival queries signings groups remaining =
+      selectedLoopInputWeight key message (fun input target => if before input = none then
+        targetShapeEnvelope uniform reuse arrival queries signings
+          (targetShapeMoments key before log (payloadOf input) target) groups remaining else 0) loop := by
+  unfold newTargetEnvelopeCharge
+  rw [digestCompletion_cacheMessageWeight_eq key message before loop hloop result hcompletion,
+    cacheMessageWeight_fresh_restriction, zero_add]
+  cases hs : loop.1 with
+  | none => simp only [selectedLoopInputWeight, hs]
+  | some selected =>
+      obtain ⟨randomness, index, leaves⟩ := selected
+      by_cases hfresh : before (tweakableHashInput key.parameter .message (messageDigestPayload key.root message randomness)) = none
+      · simp only [selectedLoopInputWeight, hs, hfresh, if_true, payloadOf_tweakableHashInput]
+        rw [digestCompletion_new_targetShapeMoments_eq key message before loop hloop result hcompletion
+          log hsigned randomness index leaves hs hfresh]
+      · simp only [selectedLoopInputWeight, hs, if_neg hfresh]
+
+theorem expected_digestCompletion_newTargetEnvelopeCharge_le_mass_mul {α : Type}
+    (key : SecretKey) (message : Message) (before : QueryCache HashSpec)
+    (finish : DigestLoopRecord → ProbComp α)
+    (record : α → (Option Signature × Option FewTimeView) × QueryCache HashSpec)
+    (hcompletion : ∀ loop ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before),
+      ∀ result ∈ support (finish loop), DigestCompletionPreservesMessages key loop (record result))
+    (log : QueryLog SigningSpec) (hsigned : SigningDigestsCached key.parameter before key.root log)
+    (uniform reuse arrival : ENNReal) (queries signings : Nat)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining) :
+    (∑' result, Pr[= result | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before >>= finish] *
+      newTargetEnvelopeCharge key before (record result).2 (log ++ [⟨message, (record result).1.1⟩])
+        uniform reuse arrival queries signings groups remaining) ≤
+      freshDigestSelectionProbability key message before *
+        ((Fintype.card Index : ENNReal)⁻¹ *
+          targetIndexEnvelope uniform reuse arrival queries signings (targetIndexMoments key before log) groups.card remaining.card) := by
+  by_cases hexists : ∃ payload, before (tweakableHashInput key.parameter .message payload) = none
+  · obtain ⟨reference, hreference⟩ := hexists
+    let weight := fun source => targetShapeEnvelope uniform reuse arrival queries signings
+      (targetShapeMoments key before log reference source) groups remaining
+    have hbound := expected_digestCompletion_freshCost_le key message before finish
+      (fun result => newTargetEnvelopeCharge key before (record result).2 (log ++ [⟨message, (record result).1.1⟩])
+        uniform reuse arrival queries signings groups remaining) weight (by
+          intro loop hl result hr
+          rw [digestCompletion_newTargetEnvelopeCharge_eq_selected key message before loop hl (record result)
+            (hcompletion loop hl result hr) log hsigned]
+          cases hs : loop.1 with
+          | none => simp only [selectedLoopInputWeight, hs, le_refl]
+          | some selected =>
+              obtain ⟨randomness, index, leaves⟩ := selected
+              by_cases hfresh : before (tweakableHashInput key.parameter .message (messageDigestPayload key.root message randomness)) = none
+              · simp only [selectedLoopInputWeight, hs, hfresh, if_true, payloadOf_tweakableHashInput, weight]
+                rw [targetShapeMoments_fresh_payload_eq key before log _ reference hfresh hreference hsigned]
+              · simp only [selectedLoopInputWeight, hs, if_neg hfresh, le_refl])
+    apply hbound.trans_eq
+    exact congrArg (fun value => freshDigestSelectionProbability key message before * value)
+      (expected_fresh_targetShapeEnvelope key before log reference hreference hsigned
+        uniform reuse arrival queries signings groups remaining hvalid)
+  · have hzero (result : α) : newTargetEnvelopeCharge key before (record result).2 (log ++ [⟨message, (record result).1.1⟩])
+        uniform reuse arrival queries signings groups remaining = 0 :=
+      newTargetEnvelopeCharge_of_no_new key before (record result).2 _ uniform reuse arrival queries signings groups remaining
+        (fun payload _ hfresh _ _ => hexists ⟨payload, hfresh⟩)
+    simp only [hzero, mul_zero, tsum_zero, zero_le]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/DigestLoopRecord.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/DigestLoopRecord.lean
new file mode 100644
index 000000000..d23a26e81
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/DigestLoopRecord.lean
@@ -0,0 +1,13 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FewTimeSignerView
+namespace SphincsSecurity.Concrete
+
+open OracleSpec
+
+abbrev DigestLoopRecord :=
+  Option (Randomness × Index × (IndexGroup → FtsLeaf)) × QueryCache HashSpec
+
+def selectedLoopView? (result : DigestLoopRecord) : Option FewTimeView :=
+  result.1.map (fun selected => selectedFewTimeView selected.2.1 selected.2.2)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/DigestMessageCost.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/DigestMessageCost.lean
new file mode 100644
index 000000000..7043b844d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/DigestMessageCost.lean
@@ -0,0 +1,127 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Reference.BoundaryMessageCost
+import SphincsSecurity.Proof.Fts.OriginalProposalExecution
+import SphincsSecurity.Proof.Base.RomQueryChargeBind
+import SphincsSecurity.Proof.Fts.UpperDigestSelection
+
+/-! ## RomQueryChargeComparison -/
+
+namespace SphincsSecurity
+
+open OracleComp OracleSpec ENNReal
+
+theorem expectedQueryCharge_lift_unif_eq_zero
+    (charge : QueryCache HashSpec → HashInput → ENNReal)
+    (computation : OracleComp unifSpec α) (cache : QueryCache HashSpec) :
+    expectedQueryCharge charge (liftM computation : OracleComp OracleWorld α) cache = 0 := by
+  induction computation using OracleComp.inductionOn generalizing cache with
+  | pure value => simp
+  | query_bind query next ih =>
+      rw [liftM_bind]
+      change expectedQueryCharge charge
+        ((liftM (OracleWorld.query (.inl query)) : OracleComp OracleWorld _) >>= fun answer => liftM (next answer)) cache = 0
+      rw [expectedQueryCharge_query_bind]
+      simp only [hashQueryCharge, Sum.elim_inl, ih, mul_zero, tsum_zero, zero_add]
+
+end SphincsSecurity
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (messageHashCharge)
+attribute [local instance] Classical.propDecidable
+noncomputable local instance instSampleableTypeRandomness_7 : SampleableType Randomness := SampleableType.ofFintype Randomness
+
+attribute [local irreducible] signDigestLoop signAttempt signWithView signAfterDigest
+set_option backward.isDefEq.respectTransparency false
+
+theorem expectedQueryCharge_messageDigest_message (key : SecretKey) (message : Message)
+    (randomness : Randomness) (cache : QueryCache HashSpec) :
+    expectedQueryCharge (messageHashCharge key.parameter)
+      (liftM (messageDigest key.parameter key.root message randomness : OracleComp HashSpec MessageDigest)) cache = 1 := by
+  change expectedQueryCharge (messageHashCharge key.parameter)
+    ((liftM (OracleWorld.query (.inr (tweakableHashInput key.parameter .message
+      (messageDigestPayload key.root message randomness)))) : OracleComp OracleWorld HashOutput) >>=
+      fun answer => pure (truncateMessageDigest answer)) cache = 1
+  rw [expectedQueryCharge_query_bind]
+  simp only [expectedQueryCharge_pure, mul_zero, tsum_zero, add_zero, hashQueryCharge, Sum.elim_inr,
+    messageHashCharge, if_pos (show FtsProbeSimulation.MessageHashInput key.parameter
+      (tweakableHashInput key.parameter .message (messageDigestPayload key.root message randomness)) from ⟨_, rfl⟩)]
+
+theorem expectedQueryCharge_signAttempt_message (key : SecretKey) (message : Message)
+    (randomness : Randomness) (cache : QueryCache HashSpec) :
+    expectedQueryCharge (messageHashCharge key.parameter)
+      (liftM (signAttempt key message randomness : OracleComp HashSpec (Option (Index × (IndexGroup → FtsLeaf))))) cache = 1 := by
+  rw [signAttempt, liftM_bind, expectedQueryCharge_bind, expectedQueryCharge_messageDigest_message]
+  conv_lhs =>
+    arg 2
+    tactic =>
+      apply ENNReal.tsum_eq_zero.mpr
+      intro result
+      split_ifs <;> simp
+  exact add_zero 1
+
+theorem expectedQueryCharge_signDigestLoop_message (attempts : Nat) (key : SecretKey)
+    (message : Message) (cache : QueryCache HashSpec) :
+    expectedQueryCharge (messageHashCharge key.parameter) (signDigestLoop attempts key message) cache =
+      digestAttemptExpectation attempts key message cache := by
+  induction attempts generalizing cache with
+  | zero => simp only [signDigestLoop, expectedQueryCharge_pure, digestAttemptExpectation]
+  | succ attempts ih =>
+      have hsample : (simulateQ romImpl (liftM sampleRandomness)).run cache =
+          (fun randomness => (randomness, cache)) <$> sampleRandomness :=
+        roSim.run_liftM (hashSpec := HashSpec)
+          (randomOracle : QueryImpl HashSpec (StateT (QueryCache HashSpec) ProbComp)) sampleRandomness cache
+      rw [signDigestLoop, expectedQueryCharge_bind, expectedQueryCharge_lift_unif_eq_zero, zero_add,
+        hsample, sampleRandomness_eq, tsum_probOutput_map_mul, digestAttemptExpectation,
+        signDigestAttemptPrefix, tsum_probOutput_bind_mul]
+      simp_rw [expectedQueryCharge_bind, expectedQueryCharge_signAttempt_message,
+        mul_add, ENNReal.tsum_add, mul_one, tsum_probOutput_of_liftM_PMF]
+      congr 1
+      apply tsum_congr
+      intro randomness
+      rw [simulateQ_romImpl_liftM]
+      congr 1
+      rw [tsum_probOutput_bind_mul]
+      apply tsum_congr
+      intro result
+      simp only [tsum_probOutput_pure_mul]
+      cases result.1 <;> simp [ih]
+
+theorem freshDigestSelection_mass_le_messageCharge (key : SecretKey) (message : Message)
+    (cache : QueryCache HashSpec) :
+    (Fintype.card FtsLeaf : ENNReal) * freshDigestSelectionProbability key message cache ≤
+      expectedQueryCharge (messageHashCharge key.parameter) (signWithView key message) cache := by
+  have h := probEvent_signDigestLoop_fresh_le_attempts_mul_admissibility digestAttemptLimit key message cache cache
+    (onlyRejectedNewMessageEntries_self cache key message)
+  have hscaled := mul_le_mul' (le_refl (Fintype.card FtsLeaf : ENNReal)) h
+  have hscalar : (Fintype.card FtsLeaf : ENNReal) *
+      (digestAttemptExpectation digestAttemptLimit key message cache * ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹) =
+      digestAttemptExpectation digestAttemptLimit key message cache := by
+    have hcard : (Fintype.card FtsLeaf : ENNReal) = ((2 ^ ftsTreeHeight : Nat) : ENNReal) := by
+      simp [FtsLeaf]
+    rw [mul_left_comm, hcard,
+      ENNReal.mul_inv_cancel (by norm_num [ftsTreeHeight]) (by finiteness), mul_one]
+  rw [hscalar] at hscaled
+  apply hscaled.trans
+  rw [signWithView, expectedQueryCharge_bind, expectedQueryCharge_signDigestLoop_message]
+  exact le_self_add
+
+private theorem expected_pmfLift {α : Type} (computation : ProbComp α) (weight : α → ENNReal) :
+    (∑' result, Pr[= result | (liftM computation : PMF α)] * weight result) =
+      ∑' result, Pr[= result | computation] * weight result := rfl
+
+theorem expected_originalProposalRecord_sign_messageCalls (key : SecretKey) (message : Message)
+    (cache : QueryCache HashSpec) :
+    (∑' record, Pr[= record | originalProposalRecord key (.inr message) cache] *
+      record.trace.messageCalls.length) =
+      expectedQueryCharge (messageHashCharge key.parameter) (signWithView key message) cache := by
+  rw [originalProposalRecord, ← PMF.monad_map_eq_map, tsum_probOutput_map_mul]
+  have h := congrArg (fun law : PMF (TracedSigningRecord SigningBoundaryTrace) =>
+    ∑' result, Pr[= result | law] * (result.1.2.messageCalls.length : ENNReal))
+    (completedSigningRecord_forget (signingBoundaryTrace key.parameter) key message cache)
+  rw [← PMF.monad_map_eq_map, tsum_probOutput_map_mul, expected_pmfLift] at h
+  change _ = expectedBoundaryMessageCalls key.parameter (signWithView key message) cache at h
+  exact h.trans (expectedBoundaryMessageCalls_eq_queryCharge key.parameter (signWithView key message) cache)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/DigestSelectionIndex.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/DigestSelectionIndex.lean
new file mode 100644
index 000000000..baf5d9d71
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/DigestSelectionIndex.lean
@@ -0,0 +1,172 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.DigestLoopRecord
+import SphincsSecurity.Proof.Fts.RawProposalMomentBound
+
+/-! ## WeightedBinomialOccupancy -/
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem uniform_view_index_weight_expectation (weight : Index → ENNReal) :
+    (∑' source, Pr[= source | ($ᵗ FewTimeView : ProbComp FewTimeView)] * weight source.1) =
+      (∑ index : Index, weight index) / (Fintype.card Index : ENNReal) := by
+  have hmarginal : ∀ index, Pr[= index | (Prod.fst <$> ($ᵗ FewTimeView : ProbComp FewTimeView))] =
+      Pr[= index | ($ᵗ Index : ProbComp Index)] := by
+    intro index
+    exact congrArg (fun distribution => distribution index)
+      (evalDist_map_fst_uniformSample_prod (α := Index) (β := FtsTree → FtsLeaf))
+  rw [← tsum_probOutput_map_mul (mx := ($ᵗ FewTimeView : ProbComp FewTimeView))
+    (f := fun source : FewTimeView => source.1) (g := weight)]
+  simp only [hmarginal, probOutput_uniformSample, tsum_fintype, div_eq_mul_inv, Finset.sum_mul]
+  apply Finset.sum_congr rfl
+  intro index _
+  exact mul_comm _ _
+
+end SphincsSecurity.Concrete
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] signDigestLoop
+
+noncomputable def completeSelectedIndex (view : Option FewTimeView) : ProbComp Index :=
+  view.elim ($ᵗ Index) (fun selected => pure selected.1)
+
+theorem probEvent_uniform_view_index (index : Index) :
+    Pr[fun view : FewTimeView => view.1 = index | ($ᵗ FewTimeView : ProbComp FewTimeView)] =
+      (Fintype.card Index : ENNReal)⁻¹ := by
+  rw [probEvent_eq_tsum_ite]
+  have h := uniform_view_index_weight_expectation
+    (fun source => if source = index then (1 : ENNReal) else 0)
+  simpa only [mul_ite, mul_one, mul_zero, Finset.sum_ite_eq', Finset.mem_univ,
+    if_true, one_div] using h
+
+theorem cachedMessageEntryCountWhere_index_le (key : SecretKey) (message : Message)
+    (cache : QueryCache HashSpec) (index : Index) :
+    cachedMessageEntryCountWhere cache key.parameter key.root message (fun view => view.1 = index) ≤
+      cachedIndexMultiplicity key.parameter cache index := by
+  let entries := cachedMessageInputSetWhere cache key.parameter key.root message (fun view => view.1 = index)
+  let inputOf : entries → HashInput := fun entry => entry.1.1
+  have hinjective : Function.Injective inputOf := by
+    rintro ⟨⟨left, leftOutput⟩, hleft⟩ ⟨⟨right, rightOutput⟩, hright⟩ heq
+    change left = right at heq
+    subst right
+    apply Subtype.ext
+    exact Sigma.ext rfl (heq_of_eq (Option.some.inj (hleft.1.1.symm.trans hright.1.1)))
+  have hweight (entry : entries) :
+      cacheMessageEntryWeight key.parameter (fun _ view => if view.1 = index then 1 else 0)
+        cache (inputOf entry) = 1 := by
+    rcases entry with ⟨⟨input, output⟩, ⟨hcached, randomness, hinput⟩, hadmissible, hindex⟩
+    change cache input = some output at hcached
+    have hmessage : FtsProbeSimulation.MessageHashInput key.parameter input :=
+      ⟨messageDigestPayload key.root message randomness, hinput.symm⟩
+    have hvalid := (signAttemptResultOfOutput_ne_none_iff output).mp hadmissible
+    simp only [inputOf, cacheMessageEntryWeight, hcached, hmessage, hvalid, and_self,
+      if_true, hindex]
+  calc
+    _ = ∑' _ : entries, (1 : ENNReal) := (ENNReal.tsum_set_one entries).symm
+    _ = ∑' entry : entries, cacheMessageEntryWeight key.parameter
+        (fun _ view => if view.1 = index then 1 else 0) cache (inputOf entry) :=
+      tsum_congr (fun entry => (hweight entry).symm)
+    _ ≤ _ := ENNReal.tsum_comp_le_tsum_of_injective hinjective _
+
+private theorem selectedLoopView_partition (attempts : Nat) (key : SecretKey) (message : Message)
+    (cache : QueryCache HashSpec) (P : FewTimeView → Prop) (result : DigestLoopRecord)
+    (hr : result ∈ support ((simulateQ romImpl (signDigestLoop attempts key message)).run cache)) :
+    (if ∃ view, selectedLoopView? result = some view ∧ P view then (1 : ENNReal) else 0) =
+      (if FreshSelectedView cache key message P result then 1 else 0) +
+        (if PrehitSelectedView cache key message P result then 1 else 0) := by
+  obtain ⟨selected, after⟩ := result
+  cases selected with
+  | none => simp [selectedLoopView?, FreshSelectedView, PrehitSelectedView]
+  | some selected =>
+      obtain ⟨randomness, index, leaves⟩ := selected
+      cases hc : cache (tweakableHashInput key.parameter .message (messageDigestPayload key.root message randomness)) with
+      | none => simp [selectedLoopView?, FreshSelectedView, PrehitSelectedView, hc]
+      | some output =>
+          have hattempt := signDigestLoop_initial_cached_result attempts key message randomness index leaves cache after output hc hr
+          have hview : selectedFewTimeView index leaves = hashOutputFewTimeView output :=
+            signAttemptResultOfOutput_view output index leaves hattempt
+          simp [selectedLoopView?, FreshSelectedView, PrehitSelectedView, hc, hattempt, hview]
+
+theorem probEvent_selectedLoopView_eq_fresh_add_cached (key : SecretKey) (message : Message)
+    (cache : QueryCache HashSpec) (P : FewTimeView → Prop) :
+    Pr[fun result => ∃ view, selectedLoopView? result = some view ∧ P view |
+      (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run cache] =
+      freshDigestSelectionProbability key message cache * Pr[P | ($ᵗ FewTimeView : ProbComp FewTimeView)] +
+        cachedMessageEntryCountWhere cache key.parameter key.root message P * exactDigestReuseWeight key message cache := by
+  unfold freshDigestSelectionProbability
+  rw [← probEvent_signDigestLoop_freshSelected_eq_mass_mul_uniform digestAttemptLimit key message cache cache P
+    (onlyRejectedNewMessageEntries_self cache key message),
+    ← probEvent_signDigestLoop_prehit_eq_count_mul_exactWeight]
+  rw [probEvent_eq_tsum_ite, probEvent_eq_tsum_ite, probEvent_eq_tsum_ite, ← ENNReal.tsum_add]
+  apply tsum_congr
+  intro result
+  by_cases hr : result ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run cache)
+  · have h := congrArg (fun value =>
+      Pr[= result | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run cache] * value)
+      (selectedLoopView_partition digestAttemptLimit key message cache P result hr)
+    simpa only [mul_add, mul_ite, mul_one, mul_zero] using h
+  · simp only [probOutput_eq_zero_of_not_mem_support hr, ite_self, zero_add]
+
+theorem probOutput_completeSelectedLoopIndex (key : SecretKey) (message : Message)
+    (cache : QueryCache HashSpec) (index : Index) :
+    Pr[= index | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run cache >>=
+      fun result => completeSelectedIndex (selectedLoopView? result)] =
+      (freshDigestSelectionProbability key message cache + digestExhaustionProbability key message cache) *
+        (Fintype.card Index : ENNReal)⁻¹ +
+      cachedMessageEntryCountWhere cache key.parameter key.root message (fun view => view.1 = index) *
+        exactDigestReuseWeight key message cache := by
+  have h := probEvent_completeOption_eq
+    ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run cache)
+    (fun result => (selectedLoopView? result).map Prod.fst) ($ᵗ Index) (fun selected => selected = index)
+  have hcomplete (view : Option FewTimeView) :
+      (view.map Prod.fst).elim ($ᵗ Index : ProbComp Index) pure = completeSelectedIndex view := by
+    cases view <;> rfl
+  have hselected (result : DigestLoopRecord) :
+      (∃ selected, (selectedLoopView? result).map Prod.fst = some selected ∧ selected = index) ↔
+        ∃ view, selectedLoopView? result = some view ∧ view.1 = index := by
+    cases selectedLoopView? result <;> simp
+  have hnone (result : DigestLoopRecord) : (selectedLoopView? result).map Prod.fst = none ↔ result.1 = none := by
+    cases hresult : result.1 <;> simp [selectedLoopView?, hresult]
+  simp only [hcomplete, hselected, hnone] at h
+  rw [probEvent_selectedLoopView_eq_fresh_add_cached, probEvent_uniform_view_index] at h
+  simpa only [probEvent_eq_eq_probOutput, probOutput_uniformSample, digestExhaustionProbability,
+    add_mul, add_assoc, add_comm, add_left_comm] using h
+
+theorem probOutput_completeSelectedLoopIndex_le (key : SecretKey) (message : Message)
+    (cache : QueryCache HashSpec) (index : Index) :
+    Pr[= index | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run cache >>=
+      fun result => completeSelectedIndex (selectedLoopView? result)] ≤
+      (Fintype.card Index : ENNReal)⁻¹ +
+        exactDigestReuseWeight key message cache * cachedIndexMultiplicity key.parameter cache index := by
+  rw [probOutput_completeSelectedLoopIndex]
+  have hmass : freshDigestSelectionProbability key message cache + digestExhaustionProbability key message cache ≤ 1 := by
+    calc
+      _ ≤ (freshDigestSelectionProbability key message cache +
+          cachedMessageEntryCountWhere cache key.parameter key.root message (fun _ => True) *
+            exactDigestReuseWeight key message cache) + digestExhaustionProbability key message cache :=
+        add_le_add le_self_add le_rfl
+      _ = 1 := freshSelection_add_count_exactWeight_add_exhaustion key message cache
+  exact add_le_add (mul_le_of_le_one_left' hmass)
+    ((mul_le_mul' (cachedMessageEntryCountWhere_index_le key message cache index) le_rfl).trans_eq (mul_comm _ _))
+
+theorem probOutput_completeSelectedLoopIndex_le_proposalRate (key : SecretKey) (message : Message)
+    (cache : QueryCache HashSpec) (spent : Nat) (hspent : spent ≤ 2 ^ 127)
+    (hcache : QueryCache.enncard cache ≤ spent) (hclean : ¬ MessageDeficitExceptional key cache)
+    (hindex : ∀ index, cachedIndexMultiplicity key.parameter cache index ≤
+      (spent : ENNReal) * ((2 ^ 36 : Nat) : ENNReal)⁻¹ + ((2 ^ 80 : Nat) : ENNReal)) (index : Index) :
+    Pr[= index | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run cache >>=
+      fun result => completeSelectedIndex (selectedLoopView? result)] ≤ targetProposalIndexRate := by
+  apply (probOutput_completeSelectedLoopIndex_le key message cache index).trans
+  apply (add_le_add le_rfl (mul_le_mul'
+    (exactDigestReuseWeight_le_near_uniform_of_clean_cache key cache spent hspent hcache hclean message) le_rfl)).trans
+  simpa only [Nat.add_zero, Nat.cast_zero, zero_mul, add_zero] using
+    targetProposalRate_of_cache_bound (cachedIndexMultiplicity key.parameter cache index)
+      spent 0 0 0 hspent (Nat.zero_le _) (Nat.zero_le _) (hindex index)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/DigestSelectionMass.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/DigestSelectionMass.lean
new file mode 100644
index 000000000..67ac50a61
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/DigestSelectionMass.lean
@@ -0,0 +1,60 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CachedDigestSelection
+import SphincsSecurity.Proof.Fts.FewTimeFreshMass
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] signDigestLoop
+
+private theorem digestSelection_partition (attempts : Nat) (key : SecretKey) (message : Message)
+    (cache : QueryCache HashSpec) (result)
+    (hr : result ∈ support ((simulateQ romImpl (signDigestLoop attempts key message)).run cache)) :
+    (if freshSelectedLoopView? cache key message result ≠ none then (1 : ENNReal) else 0) +
+      (if PrehitSelectedView cache key message (fun _ => True) result then 1 else 0) +
+      (if result.1 = none then 1 else 0) = 1 := by
+  obtain ⟨selected, after⟩ := result
+  cases selected with
+  | none => simp [freshSelectedLoopView?, PrehitSelectedView]
+  | some selected =>
+      obtain ⟨randomness, index, leaves⟩ := selected
+      cases hc : cache (tweakableHashInput key.parameter .message (messageDigestPayload key.root message randomness)) with
+      | none => simp [freshSelectedLoopView?, PrehitSelectedView, hc]
+      | some output =>
+          have hp : PrehitSelectedView cache key message (fun _ => True) (some (randomness, index, leaves), after) :=
+            ⟨randomness, index, leaves, rfl, output, hc,
+              signDigestLoop_initial_cached_result attempts key message randomness index leaves cache after output hc hr, trivial⟩
+          simp only [freshSelectedLoopView?, hc, Option.some_ne_none, if_false, ne_eq, not_true_eq_false, hp,
+            if_true, zero_add, add_zero]
+
+theorem probEvent_signDigestLoop_selection_mass (attempts : Nat) (key : SecretKey) (message : Message)
+    (cache : QueryCache HashSpec) :
+    Pr[fun result => freshSelectedLoopView? cache key message result ≠ none |
+        (simulateQ romImpl (signDigestLoop attempts key message)).run cache] +
+      Pr[PrehitSelectedView cache key message (fun _ => True) |
+        (simulateQ romImpl (signDigestLoop attempts key message)).run cache] +
+      Pr[fun result => result.1 = none | (simulateQ romImpl (signDigestLoop attempts key message)).run cache] = 1 := by
+  rw [probEvent_eq_tsum_ite, probEvent_eq_tsum_ite, probEvent_eq_tsum_ite, ← ENNReal.tsum_add, ← ENNReal.tsum_add]
+  calc
+    _ = ∑' result, Pr[= result | (simulateQ romImpl (signDigestLoop attempts key message)).run cache] := by
+      apply tsum_congr
+      intro result
+      by_cases hr : result ∈ support ((simulateQ romImpl (signDigestLoop attempts key message)).run cache)
+      · have h := congrArg (fun value => Pr[= result | (simulateQ romImpl (signDigestLoop attempts key message)).run cache] * value)
+          (digestSelection_partition attempts key message cache result hr)
+        simpa only [mul_add, mul_ite, mul_one, mul_zero] using h
+      · simp only [probOutput_eq_zero_of_not_mem_support hr, ite_self, zero_add]
+    _ = 1 := tsum_probOutput_of_liftM_PMF _
+
+noncomputable def digestExhaustionProbability (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) : ENNReal :=
+  Pr[fun result => result.1 = none | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run cache]
+
+theorem freshSelection_add_cachedAttempts_add_exhaustion (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) :
+    freshDigestSelectionProbability key message cache +
+      cachedDigestAttemptRate key message cache (fun _ => True) * digestAttemptExpectation digestAttemptLimit key message cache +
+      digestExhaustionProbability key message cache = 1 := by
+  have h := probEvent_signDigestLoop_selection_mass digestAttemptLimit key message cache
+  rw [probEvent_signDigestLoop_prehit_eq_rate_mul_attempts digestAttemptLimit key message cache cache le_rfl] at h
+  exact h
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/DigestSelectionWeight.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/DigestSelectionWeight.lean
new file mode 100644
index 000000000..5a9f15863
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/DigestSelectionWeight.lean
@@ -0,0 +1,251 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CacheMessageSignerWeight
+import SphincsSecurity.Proof.Fts.CachedDigestRate
+import SphincsSecurity.Proof.Fts.DigestLoopRecord
+import SphincsSecurity.Proof.Fts.FewTimeFixedPrehit
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] signDigestLoop
+
+def selectedLoopInputWeight (key : SecretKey) (message : Message)
+    (weight : HashInput → FewTimeView → ENNReal) (result : DigestLoopRecord) : ENNReal :=
+  match result.1 with
+  | none => 0
+  | some (randomness, index, leaves) => weight
+      (tweakableHashInput key.parameter .message (messageDigestPayload key.root message randomness))
+      (selectedFewTimeView index leaves)
+
+theorem probEvent_signDigestLoop_fixedPrehit_le_exactWeight
+    (key : SecretKey) (message : Message) (cache : QueryCache HashSpec)
+    (input : HashInput) (P : FewTimeView → Prop) :
+    Pr[PrehitSelectedView (onlyInputCache cache input) key message P |
+      (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run cache] ≤
+      exactDigestReuseWeight key message cache := by
+  rw [probEvent_signDigestLoop_prehit_eq_rate_mul_attempts digestAttemptLimit key message
+    (onlyInputCache cache input) cache (onlyInputCache_le cache input), cachedDigestAttemptRate_eq_count]
+  calc
+    _ = cachedMessageEntryCountWhere (onlyInputCache cache input) key.parameter key.root message P *
+        exactDigestReuseWeight key message cache := by unfold exactDigestReuseWeight; ring
+    _ ≤ 1 * exactDigestReuseWeight key message cache := mul_le_mul'
+      (cachedMessageEntryCountWhere_onlyInput_le_one cache input key.parameter key.root message P) le_rfl
+    _ = _ := one_mul _
+
+theorem selectedLoopInputWeight_le_fresh_add_prehit
+    (key : SecretKey) (message : Message) (before : QueryCache HashSpec)
+    (weight : HashInput → FewTimeView → ENNReal) (uniformWeight : FewTimeView → ENNReal)
+    (hweight : ∀ input view, weight input view ≤ uniformWeight view)
+    (result : DigestLoopRecord)
+    (hresult : result ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before)) :
+    selectedLoopInputWeight key message weight result ≤
+      (∑' view, if FreshSelectedView before key message (· = view) result then uniformWeight view else 0) +
+      (∑' input, if PrehitSelectedView (onlyInputCache before input) key message (fun _ => True) result then
+        cachedSignerInputWeight key message before weight input else 0) := by
+  obtain ⟨selected, after⟩ := result
+  cases selected with
+  | none => simp only [selectedLoopInputWeight]; exact bot_le
+  | some selected =>
+      obtain ⟨randomness, index, leaves⟩ := selected
+      let input := tweakableHashInput key.parameter .message (messageDigestPayload key.root message randomness)
+      let view := selectedFewTimeView index leaves
+      change weight input view ≤ _
+      cases hbefore : before input with
+      | none =>
+          have hfresh : FreshSelectedView before key message (· = view) (some (randomness, index, leaves), after) :=
+            ⟨randomness, index, leaves, rfl, hbefore, rfl⟩
+          apply (hweight input view).trans
+          apply le_trans ?_ le_self_add
+          exact (le_of_eq (if_pos hfresh).symm).trans (ENNReal.le_tsum view)
+      | some output =>
+          have hattempt := signDigestLoop_initial_cached_result digestAttemptLimit key message randomness
+            index leaves before after output hbefore hresult
+          have hview : view = hashOutputFewTimeView output := signAttemptResultOfOutput_view output index leaves hattempt
+          have hadmissible : Admissible (truncateMessageDigest output) :=
+            (signAttemptResultOfOutput_ne_none_iff output).mp (by rw [hattempt]; exact Option.some_ne_none _)
+          have hsource : cachedSignerInputWeight key message before weight input = weight input view := by
+            simp only [cachedSignerInputWeight, hbefore]
+            rw [if_pos ⟨⟨randomness, rfl⟩, hadmissible⟩, ← hview]
+          have hprehit : PrehitSelectedView (onlyInputCache before input) key message (fun _ => True)
+              (some (randomness, index, leaves), after) := by
+            refine ⟨randomness, index, leaves, rfl, output, ?_, hattempt, trivial⟩
+            simpa [onlyInputCache, input] using hbefore
+          apply le_trans ?_ (le_add_left le_rfl)
+          rw [← hsource]
+          exact (le_of_eq (if_pos hprehit).symm).trans (ENNReal.le_tsum input)
+
+theorem expected_selectedLoopInputWeight_le_exactReuse
+    (key : SecretKey) (message : Message) (before : QueryCache HashSpec)
+    (weight : HashInput → FewTimeView → ENNReal) (uniformWeight : FewTimeView → ENNReal)
+    (hweight : ∀ input view, weight input view ≤ uniformWeight view) :
+    (∑' result, Pr[= result | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before] *
+      selectedLoopInputWeight key message weight result) ≤
+      freshDigestSelectionProbability key message before *
+        (∑' view, Pr[= view | ($ᵗ FewTimeView : ProbComp FewTimeView)] * uniformWeight view) +
+      (∑' input, cachedSignerInputWeight key message before weight input) * exactDigestReuseWeight key message before := by
+  have hexpect {α : Type} (event : α → DigestLoopRecord → Prop) (value : α → ENNReal) :
+      (∑' result, Pr[= result | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before] *
+        ∑' index, if event index result then value index else 0) =
+      ∑' index, Pr[event index | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before] * value index := by
+    simp only [← ENNReal.tsum_mul_left]
+    rw [ENNReal.tsum_comm]
+    apply tsum_congr
+    intro index
+    rw [probEvent_eq_tsum_ite, ← ENNReal.tsum_mul_right]
+    apply tsum_congr
+    intro result
+    split_ifs <;> simp
+  calc
+    _ ≤ ∑' result, Pr[= result | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before] *
+        ((∑' view, if FreshSelectedView before key message (· = view) result then uniformWeight view else 0) +
+          ∑' input, if PrehitSelectedView (onlyInputCache before input) key message (fun _ => True) result then
+            cachedSignerInputWeight key message before weight input else 0) := by
+      apply ENNReal.tsum_le_tsum
+      intro result
+      by_cases hr : result ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before)
+      · exact mul_le_mul' le_rfl (selectedLoopInputWeight_le_fresh_add_prehit key message before weight uniformWeight hweight result hr)
+      · rw [probOutput_eq_zero_of_not_mem_support hr, zero_mul, zero_mul]
+    _ = (∑' view, Pr[FreshSelectedView before key message (· = view) |
+          (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before] * uniformWeight view) +
+        ∑' input, Pr[PrehitSelectedView (onlyInputCache before input) key message (fun _ => True) |
+          (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before] *
+            cachedSignerInputWeight key message before weight input := by
+      simp only [mul_add, ENNReal.tsum_add, hexpect]
+    _ ≤ (∑' view, (freshDigestSelectionProbability key message before *
+          Pr[= view | ($ᵗ FewTimeView : ProbComp FewTimeView)]) * uniformWeight view) +
+        ∑' input, exactDigestReuseWeight key message before * cachedSignerInputWeight key message before weight input := by
+      apply add_le_add
+      · apply ENNReal.tsum_le_tsum
+        intro view
+        apply mul_le_mul' _ le_rfl
+        exact le_of_eq (by
+          simpa only [probEvent_eq_eq_probOutput, freshDigestSelectionProbability] using
+            (probEvent_signDigestLoop_freshSelected_eq_mass_mul_uniform digestAttemptLimit key message before before (· = view)
+              (onlyRejectedNewMessageEntries_self before key message)))
+      · exact ENNReal.tsum_le_tsum (fun input => mul_le_mul'
+          (probEvent_signDigestLoop_fixedPrehit_le_exactWeight key message before input (fun _ => True)) le_rfl)
+    _ = _ := by simp only [mul_assoc, ENNReal.tsum_mul_left]; rw [mul_comm (exactDigestReuseWeight key message before)]
+
+theorem expected_freshSelectedLoopInputWeight_le (key : SecretKey) (message : Message) (before : QueryCache HashSpec)
+    (weight : FewTimeView → ENNReal) :
+    (∑' loop, Pr[= loop | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before] *
+      selectedLoopInputWeight key message (fun input source => if before input = none then weight source else 0) loop) ≤
+      freshDigestSelectionProbability key message before *
+        ∑' source, Pr[= source | ($ᵗ FewTimeView : ProbComp FewTimeView)] * weight source := by
+  have hzero (input : HashInput) : cachedSignerInputWeight key message before
+      (fun input source => if before input = none then weight source else 0) input = 0 := by
+    unfold cachedSignerInputWeight
+    cases hc : before input with
+    | none => rfl
+    | some output => simp only [hc, reduceCtorEq, if_false, ite_self]
+  have hbound := expected_selectedLoopInputWeight_le_exactReuse key message before
+    (fun input source => if before input = none then weight source else 0) weight (by
+      intro input source
+      split_ifs; exact le_rfl; exact bot_le)
+  simpa only [hzero, tsum_zero, zero_mul, add_zero] using hbound
+
+def DigestCompletionConsistent (loop : DigestLoopRecord)
+    (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec) : Prop :=
+  result.1.2 = selectedLoopView? loop ∧
+    ∀ signature, result.1.1 = some signature →
+      ∃ index leaves, loop.1 = some (signature.randomness, index, leaves)
+
+theorem successfulSignerInputWeight_le_selectedLoopInputWeight
+    (key : SecretKey) (message : Message) (weight : HashInput → FewTimeView → ENNReal)
+    (loop : DigestLoopRecord) (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec)
+    (hconsistent : DigestCompletionConsistent loop result) :
+    successfulSignerInputWeight key message weight result ≤ selectedLoopInputWeight key message weight loop := by
+  cases hs : result.1.1 with
+  | none => simp only [successfulSignerInputWeight, hs]; exact bot_le
+  | some signature =>
+      obtain ⟨index, leaves, hloop⟩ := hconsistent.2 signature hs
+      simp only [successfulSignerInputWeight, hs, hconsistent.1, selectedLoopView?, hloop,
+        Option.map_some, selectedLoopInputWeight, le_refl]
+
+theorem expected_digestCompletion_cost_le_selected {α : Type}
+    (key : SecretKey) (message : Message) (before : QueryCache HashSpec)
+    (finish : DigestLoopRecord → ProbComp α) (cost : α → ENNReal)
+    (weight : HashInput → FewTimeView → ENNReal)
+    (hcost : ∀ loop ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before),
+      ∀ result ∈ support (finish loop), cost result ≤ selectedLoopInputWeight key message weight loop) :
+    (∑' result, Pr[= result | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before >>= finish] * cost result) ≤
+      ∑' loop, Pr[= loop | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before] *
+        selectedLoopInputWeight key message weight loop := by
+  rw [tsum_probOutput_bind_mul]
+  apply ENNReal.tsum_le_tsum
+  intro loop
+  by_cases hl : loop ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before)
+  · apply mul_le_mul' le_rfl
+    calc
+      _ ≤ ∑' result, Pr[= result | finish loop] * selectedLoopInputWeight key message weight loop := by
+        apply ENNReal.tsum_le_tsum
+        intro result
+        by_cases hr : result ∈ support (finish loop)
+        · exact mul_le_mul' le_rfl (hcost loop hl result hr)
+        · rw [probOutput_eq_zero_of_not_mem_support hr, zero_mul, zero_mul]
+      _ ≤ _ := by rw [ENNReal.tsum_mul_right]; exact mul_le_of_le_one_left' tsum_probOutput_le_one
+  · rw [probOutput_eq_zero_of_not_mem_support hl, zero_mul, zero_mul]
+
+theorem expected_digestCompletion_successfulInputWeight_le_selected {α : Type}
+    (key : SecretKey) (message : Message) (before : QueryCache HashSpec)
+    (finish : DigestLoopRecord → ProbComp α)
+    (record : α → (Option Signature × Option FewTimeView) × QueryCache HashSpec)
+    (hconsistent : ∀ loop ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before),
+      ∀ result ∈ support (finish loop), DigestCompletionConsistent loop (record result))
+    (weight : HashInput → FewTimeView → ENNReal) :
+    (∑' result, Pr[= result | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before >>= finish] *
+      successfulSignerInputWeight key message weight (record result)) ≤
+      ∑' loop, Pr[= loop | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before] *
+        selectedLoopInputWeight key message weight loop :=
+  expected_digestCompletion_cost_le_selected key message before finish
+    (fun result => successfulSignerInputWeight key message weight (record result)) weight
+    (fun loop hl result hr => successfulSignerInputWeight_le_selectedLoopInputWeight
+      key message weight loop (record result) (hconsistent loop hl result hr))
+
+theorem expected_digestCompletion_freshCost_le {α : Type}
+    (key : SecretKey) (message : Message) (before : QueryCache HashSpec)
+    (finish : DigestLoopRecord → ProbComp α) (cost : α → ENNReal) (weight : FewTimeView → ENNReal)
+    (hcost : ∀ loop ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before),
+      ∀ result ∈ support (finish loop), cost result ≤
+        selectedLoopInputWeight key message (fun input source => if before input = none then weight source else 0) loop) :
+    (∑' result, Pr[= result | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before >>= finish] * cost result) ≤
+      freshDigestSelectionProbability key message before *
+        ∑' source, Pr[= source | ($ᵗ FewTimeView : ProbComp FewTimeView)] * weight source :=
+  (expected_digestCompletion_cost_le_selected key message before finish cost _ hcost).trans
+    (expected_freshSelectedLoopInputWeight_le key message before weight)
+
+theorem expected_digestCompletion_successfulInputWeight_le_exactReuse {α : Type}
+    (key : SecretKey) (message : Message) (before : QueryCache HashSpec)
+    (finish : DigestLoopRecord → ProbComp α)
+    (record : α → (Option Signature × Option FewTimeView) × QueryCache HashSpec)
+    (hconsistent : ∀ loop ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before),
+      ∀ result ∈ support (finish loop), DigestCompletionConsistent loop (record result))
+    (weight : HashInput → FewTimeView → ENNReal) (uniformWeight : FewTimeView → ENNReal)
+    (hweight : ∀ input view, weight input view ≤ uniformWeight view) :
+    (∑' result, Pr[= result | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before >>= finish] *
+      successfulSignerInputWeight key message weight (record result)) ≤
+      freshDigestSelectionProbability key message before *
+        (∑' view, Pr[= view | ($ᵗ FewTimeView : ProbComp FewTimeView)] * uniformWeight view) +
+      (∑' input, cachedSignerInputWeight key message before weight input) * exactDigestReuseWeight key message before :=
+  (expected_digestCompletion_successfulInputWeight_le_selected key message before finish record hconsistent weight).trans
+    (expected_selectedLoopInputWeight_le_exactReuse key message before weight uniformWeight hweight)
+
+theorem expected_digestCompletion_successfulInputWeight_le_allMessage {α : Type}
+    (key : SecretKey) (message : Message) (before : QueryCache HashSpec)
+    (finish : DigestLoopRecord → ProbComp α)
+    (record : α → (Option Signature × Option FewTimeView) × QueryCache HashSpec)
+    (hconsistent : ∀ loop ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before),
+      ∀ result ∈ support (finish loop), DigestCompletionConsistent loop (record result))
+    (weight : HashInput → FewTimeView → ENNReal) (uniformWeight : FewTimeView → ENNReal)
+    (hweight : ∀ input view, weight input view ≤ uniformWeight view)
+    (reuse : ENNReal) (hreuse : exactDigestReuseWeight key message before ≤ reuse) :
+    (∑' result, Pr[= result | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before >>= finish] *
+      successfulSignerInputWeight key message weight (record result)) ≤
+      freshDigestSelectionProbability key message before *
+        (∑' view, Pr[= view | ($ᵗ FewTimeView : ProbComp FewTimeView)] * uniformWeight view) +
+      cacheMessageWeight key.parameter weight before * reuse :=
+  (expected_digestCompletion_successfulInputWeight_le_exactReuse key message before finish record hconsistent
+    weight uniformWeight hweight).trans (add_le_add le_rfl (mul_le_mul'
+      (ENNReal.tsum_le_tsum (cachedSignerInputWeight_le_cacheMessageEntryWeight key message before weight)) hreuse))
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/DigestSigningCompletion.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/DigestSigningCompletion.lean
new file mode 100644
index 000000000..124f25a0e
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/DigestSigningCompletion.lean
@@ -0,0 +1,83 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.DigestSelectionWeight
+import SphincsSecurity.Proof.Fts.SelectedDigestCache
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (messageAnswers)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] signDigestLoop signAfterDigest signWithView
+
+def DigestCompletionPreservesMessages (key : SecretKey) (loop : DigestLoopRecord)
+    (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec) : Prop :=
+  DigestCompletionConsistent loop result ∧ messageAnswers key.parameter result.2 = messageAnswers key.parameter loop.2
+
+theorem digestCompletion_successful_cached_output (key : SecretKey) (message : Message) (before : QueryCache HashSpec)
+    (loop : DigestLoopRecord)
+    (hloop : loop ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before))
+    (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec)
+    (hcompletion : DigestCompletionPreservesMessages key loop result)
+    (signature : Signature) (hs : result.1.1 = some signature) :
+    ∃ output, result.2 (tweakableHashInput key.parameter .message
+        (messageDigestPayload key.root message signature.randomness)) = some output ∧
+      Admissible (truncateMessageDigest output) ∧ result.1.2 = some (hashOutputFewTimeView output) := by
+  obtain ⟨index, leaves, hselected⟩ := hcompletion.1.2 signature hs
+  have hloop' : (some (signature.randomness, index, leaves), loop.2) ∈ support
+      ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before) := by
+    have heq : loop = (some (signature.randomness, index, leaves), loop.2) := Prod.ext hselected rfl
+    rwa [← heq]
+  obtain ⟨output, hcached, hadmissible, hview⟩ := signDigestLoop_selected_cached_output
+    digestAttemptLimit key message before loop.2 signature.randomness index leaves hloop'
+  refine ⟨output, ?_, hadmissible, ?_⟩
+  · exact (congrFun hcompletion.2 (messageDigestPayload key.root message signature.randomness)).trans hcached
+  · simp only [hcompletion.1.1, selectedLoopView?, hselected, Option.map_some, ← hview]
+
+noncomputable def originalDigestCompletion (key : SecretKey) (loop : DigestLoopRecord) :
+    ProbComp ((Option Signature × Option FewTimeView) × QueryCache HashSpec) :=
+  match loop.1 with
+  | none => pure ((none, none), loop.2)
+  | some (randomness, index, leaves) =>
+      (fun result => ((result.1, some (selectedFewTimeView index leaves)), result.2)) <$>
+        (simulateQ (randomOracle : QueryImpl HashSpec _) (signAfterDigest key randomness index leaves)).run loop.2
+
+theorem signWithView_run_eq_digestCompletion (key : SecretKey) (message : Message) (before : QueryCache HashSpec) :
+    (simulateQ romImpl (signWithView key message)).run before =
+      (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before >>= originalDigestCompletion key := by
+  rw [signWithView, simulateQ_bind, StateT.run_bind]
+  apply bind_congr
+  intro loop
+  cases hl : loop.1 with
+  | none => simp only [originalDigestCompletion, hl, simulateQ_pure, StateT.run_pure]
+  | some selected =>
+      obtain ⟨randomness, index, leaves⟩ := selected
+      simp only [originalDigestCompletion, hl, simulateQ_bind, StateT.run_bind, simulateQ_pure, StateT.run_pure,
+        simulateQ_romImpl_liftM, map_eq_bind_pure_comp]
+      rfl
+
+theorem originalDigestCompletion_preservesMessages (key : SecretKey) (loop : DigestLoopRecord)
+    (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec)
+    (hr : result ∈ support (originalDigestCompletion key loop)) :
+    DigestCompletionPreservesMessages key loop result := by
+  cases hl : loop.1 with
+  | none =>
+      have heq : result = ((none, none), loop.2) := by
+        simpa only [originalDigestCompletion, hl, support_pure, Set.mem_singleton_iff] using hr
+      subst result
+      simp only [DigestCompletionPreservesMessages, DigestCompletionConsistent, selectedLoopView?, hl,
+        Option.map_none, reduceCtorEq, false_implies, implies_true, and_self]
+  | some selected =>
+      obtain ⟨randomness, index, leaves⟩ := selected
+      simp only [originalDigestCompletion, hl, support_map] at hr
+      obtain ⟨⟨signature, after⟩, hfinish, rfl⟩ := hr
+      refine ⟨⟨?_, ?_⟩, ?_⟩
+      · simp only [selectedLoopView?, hl, Option.map_some]
+      · intro successful hs
+        have hfinish' : (some successful, after) ∈ support
+            ((simulateQ (randomOracle : QueryImpl HashSpec _) (signAfterDigest key randomness index leaves)).run loop.2) := by
+          rwa [← hs]
+        have hrandomness := signAfterDigest_support_some_randomness key randomness index leaves loop.2 after successful hfinish'
+        exact ⟨index, leaves, by simpa only [hrandomness] using hl⟩
+      · funext payload
+        exact signAfterDigest_message_cache_eq key randomness index leaves loop.2 after signature hfinish payload
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/ExactTargetShapeSigning.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/ExactTargetShapeSigning.lean
new file mode 100644
index 000000000..255c4169f
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/ExactTargetShapeSigning.lean
@@ -0,0 +1,187 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.DigestCompletionCacheGrowth
+import SphincsSecurity.Proof.Fts.ConcreteTargetShapeQuery
+import SphincsSecurity.Proof.Fts.InterleavedCoverStep
+
+/-! ## WorldTargetShapeEnvelope -/
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def observedTargetShapeVector (key : SecretKey) (payload : HashInput) (target : FewTimeView) (state : CoverLogState) : TargetShapeVector :=
+  targetShapeMoments key state.1 state.2 payload target
+
+theorem expected_fresh_targetShape_le (key : SecretKey) (payload : HashInput) (target : FewTimeView)
+    (before : QueryCache HashSpec) (log : QueryLog SigningSpec) (input : HashInput) (hfresh : before input = none)
+    (hsigned : SigningDigestsCached key.parameter before key.root log)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining) :
+    (∑' output, Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] *
+      observedTargetShapeVector key payload target (before.cacheQuery input output, log) groups remaining) ≤
+        targetShapeQuery (((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ * (Fintype.card Index : ENNReal)⁻¹)
+          (observedTargetShapeVector key payload target (before, log)) groups remaining := by
+  have h := expected_randomOracle_targetShapeMoments_le key before log payload target groups remaining hvalid input hsigned
+  rw [randomOracle, QueryImpl.withCaching_run_none _ hfresh, tsum_probOutput_map_mul] at h
+  exact h
+
+end SphincsSecurity.Concrete
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+
+noncomputable def reuseTargetMixedSigningEnvelope (key : SecretKey) (cache : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView)
+    (groups : Fin m → Finset FtsTree) (required : Finset FtsTree) (reuse : ENNReal) : ENNReal :=
+  normalizedTargetCacheProduct key.parameter cache (tweakableHashInput key.parameter .message payload) target groups *
+    (normalizedTargetLogProduct key cache log payload target required +
+      (Fintype.card Index : ENNReal)⁻¹ * (∑ selected ∈ required.powerset.erase ∅, normalizedTargetLogProduct key cache log payload target (required \ selected)) +
+      (∑ selected ∈ required.powerset.erase ∅,
+        normalizedCachedTargetSubsetMatch key.parameter cache (tweakableHashInput key.parameter .message payload) target selected *
+          normalizedTargetLogProduct key cache log payload target (required \ selected)) * reuse) +
+    (Fintype.card Index : ENNReal)⁻¹ *
+      ∑ selected ∈ (Finset.univ : Finset (Fin m)).powerset.erase ∅,
+        ∑ trees ∈ required.powerset,
+          (∏ slot ∈ (Finset.univ : Finset (Fin m)) \ selected,
+            normalizedCachedTargetSubsetMatch key.parameter cache (tweakableHashInput key.parameter .message payload) target (groups slot)) *
+              normalizedTargetLogProduct key cache log payload target (required \ trees)
+
+theorem digestCompletion_normalizedTargetMixedMoment_eq_frozen_add_growth (key : SecretKey) (message : Message)
+    (before : QueryCache HashSpec) (loop : DigestLoopRecord)
+    (hloop : loop ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before))
+    (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec)
+    (hcompletion : DigestCompletionPreservesMessages key loop result)
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView)
+    (groups : Fin m → Finset FtsTree) (required : Finset FtsTree) :
+    normalizedTargetMixedMoment key result.2 log payload target groups required =
+      normalizedTargetCacheProduct key.parameter before (tweakableHashInput key.parameter .message payload) target groups *
+        normalizedTargetLogProduct key result.2 log payload target required +
+          targetMixedSigningGrowth key before result.2 log payload target groups required := by
+  have hmono : normalizedTargetCacheProduct key.parameter before (tweakableHashInput key.parameter .message payload) target groups ≤
+      normalizedTargetCacheProduct key.parameter result.2 (tweakableHashInput key.parameter .message payload) target groups := by
+    apply Finset.prod_le_prod'
+    intro slot _
+    simp only [normalizedCachedTargetSubsetMatch_eq_weight]
+    rw [digestCompletion_cacheMessageWeight_eq key message before loop hloop result hcompletion]
+    exact le_self_add
+  unfold normalizedTargetMixedMoment targetMixedSigningGrowth
+  rw [← add_mul, add_tsub_cancel_of_le hmono]
+
+theorem expected_digestCompletion_normalizedTargetMixedMoment_le_of_exactReuse {α : Type} (key : SecretKey) (message : Message) (before : QueryCache HashSpec)
+    (finish : DigestLoopRecord → ProbComp α)
+    (record : α → (Option Signature × Option FewTimeView) × QueryCache HashSpec)
+    (hcompletion : ∀ loop ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before),
+      ∀ result ∈ support (finish loop), DigestCompletionPreservesMessages key loop (record result))
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView)
+    (groups : Fin m → Finset FtsTree) (required : Finset FtsTree)
+    (hgroups : ∀ slot, (groups slot).Nonempty) (hdisjoint : Pairwise (fun i j => Disjoint (groups i) (groups j)))
+    (hremaining : ∀ slot, Disjoint (groups slot) required)
+    (hsigned : SigningDigestsCached key.parameter before key.root log)
+    (reuse : ENNReal) (hreuse : exactDigestReuseWeight key message before ≤ reuse) :
+    (∑' result, Pr[= result | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before >>= finish] *
+      normalizedTargetMixedMoment key (record result).2 (log ++ [⟨message, (record result).1.1⟩]) payload target groups required) ≤
+      reuseTargetMixedSigningEnvelope key before log payload target groups required reuse := by
+  have heq : (∑' result, Pr[= result | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before >>= finish] *
+      normalizedTargetMixedMoment key (record result).2 (log ++ [⟨message, (record result).1.1⟩]) payload target groups required) =
+      normalizedTargetCacheProduct key.parameter before (tweakableHashInput key.parameter .message payload) target groups *
+        (∑' result, Pr[= result | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before >>= finish] *
+          normalizedTargetLogProduct key (record result).2 (log ++ [⟨message, (record result).1.1⟩]) payload target required) +
+      ∑' result, Pr[= result | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before >>= finish] *
+        targetMixedSigningGrowth key before (record result).2 (log ++ [⟨message, (record result).1.1⟩]) payload target groups required := by
+    rw [← ENNReal.tsum_mul_left, ← ENNReal.tsum_add]
+    apply tsum_congr
+    intro result
+    by_cases hresult : result ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before >>= finish)
+    · rw [mem_support_bind_iff] at hresult
+      obtain ⟨loop, hl, hr⟩ := hresult
+      rw [digestCompletion_normalizedTargetMixedMoment_eq_frozen_add_growth key message before loop hl (record result)
+        (hcompletion loop hl result hr) _ payload target groups required]
+      ring
+    · rw [probOutput_eq_zero_of_not_mem_support hresult]
+      simp only [zero_mul, mul_zero, add_zero]
+  rw [heq]
+  apply add_le_add
+  · exact mul_le_mul' le_rfl (expected_digestCompletion_normalizedTargetLogProduct_le_of_exactReuse key message before finish record hcompletion log payload target required hsigned reuse hreuse)
+  · apply ((expected_digestCompletion_targetMixedGrowth_le_freshMass key message before finish record hcompletion
+      log payload target groups required hsigned).trans
+        (mul_le_of_le_one_left' (freshDigestSelectionProbability_le_one key message before))).trans_eq
+    exact expected_targetMixedGrowthPolynomial _ _ groups required target hgroups hdisjoint hremaining
+
+theorem targetShapeSigning_eq_reuseIndexedEnvelope (key : SecretKey) (cache : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining) (reuse : ENNReal) :
+    targetShapeSigning (Fintype.card Index : ENNReal)⁻¹ reuse
+      (targetShapeMoments key cache log payload target) groups remaining =
+        reuseTargetMixedSigningEnvelope key cache log payload target (targetGroupAt groups) remaining reuse := by
+  unfold reuseTargetMixedSigningEnvelope
+  rw [targetShapeMoments_cross_eq]
+  simp only [normalizedTargetCacheProduct, prod_targetGroupAt]
+  unfold targetShapeSigning
+  rw [targetShapeMoments_reuse_eq key cache log payload target groups remaining hvalid]
+  have htree : targetTreeLower (targetShapeMoments key cache log payload target) groups remaining =
+      (∏ group ∈ groups, normalizedCachedTargetSubsetMatch key.parameter cache
+        (tweakableHashInput key.parameter .message payload) target group) *
+          ∑ trees ∈ remaining.powerset.erase ∅, normalizedTargetLogProduct key cache log payload target (remaining \ trees) := by
+    simp only [targetTreeLower, targetShapeMoments, Finset.mul_sum]
+  rw [htree]
+  unfold targetShapeMoments
+  ring
+
+theorem expected_digestCompletion_targetShapeMoments_le_of_exactReuse {α : Type} (key : SecretKey) (message : Message) (before : QueryCache HashSpec)
+    (finish : DigestLoopRecord → ProbComp α)
+    (record : α → (Option Signature × Option FewTimeView) × QueryCache HashSpec)
+    (hcompletion : ∀ loop ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before),
+      ∀ result ∈ support (finish loop), DigestCompletionPreservesMessages key loop (record result))
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining)
+    (hsigned : SigningDigestsCached key.parameter before key.root log)
+    (reuse : ENNReal) (hreuse : exactDigestReuseWeight key message before ≤ reuse) :
+    (∑' result, Pr[= result | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run before >>= finish] *
+      targetShapeMoments key (record result).2 (log ++ [⟨message, (record result).1.1⟩]) payload target groups remaining) ≤
+        targetShapeSigning (Fintype.card Index : ENNReal)⁻¹ reuse
+          (targetShapeMoments key before log payload target) groups remaining := by
+  simp only [targetShapeMoments_eq_indexed]
+  rw [targetShapeSigning_eq_reuseIndexedEnvelope key before log payload target groups remaining hvalid reuse]
+  exact expected_digestCompletion_normalizedTargetMixedMoment_le_of_exactReuse key message before finish record hcompletion log payload target (targetGroupAt groups) remaining
+    (fun slot => hvalid.nonempty _ (targetGroupAt_mem groups slot))
+    (fun i j hij => hvalid.disjoint _ (targetGroupAt_mem groups i) _ (targetGroupAt_mem groups j)
+      (fun heq => hij (targetGroupAt_injective groups heq)))
+    (fun slot => hvalid.remaining _ (targetGroupAt_mem groups slot)) hsigned reuse hreuse
+
+theorem expected_signWithView_targetShapeMoments_le_of_exactReuse (key : SecretKey) (message : Message) (before : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining)
+    (hsigned : SigningDigestsCached key.parameter before key.root log)
+    (reuse : ENNReal) (hreuse : exactDigestReuseWeight key message before ≤ reuse) :
+    (∑' result, Pr[= result | (simulateQ romImpl (signWithView key message)).run before] *
+      targetShapeMoments key result.2 (log ++ [⟨message, result.1.1⟩]) payload target groups remaining) ≤
+        targetShapeSigning (Fintype.card Index : ENNReal)⁻¹ reuse
+          (targetShapeMoments key before log payload target) groups remaining := by
+  rw [signWithView_run_eq_digestCompletion]
+  exact expected_digestCompletion_targetShapeMoments_le_of_exactReuse key message before
+    (originalDigestCompletion key) id (fun loop _ result hr => originalDigestCompletion_preservesMessages key loop result hr)
+    log payload target groups remaining hvalid hsigned reuse hreuse
+
+theorem expected_logTraced_sign_targetShape_le_of_exactReuse (key : SecretKey) (reuse : ENNReal)
+    (payload : HashInput) (target : FewTimeView) (state : CoverLogState)
+    (hsigned : SigningDigestsCached key.parameter state.1 key.root state.2)
+    (message : Message) (hreuse : exactDigestReuseWeight key message state.1 ≤ reuse)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining) :
+    (∑' result, Pr[= result | (logTracedMappedAdversaryImpl key (.inr message)).run state] *
+      observedTargetShapeVector key payload target result.2 groups remaining) ≤
+        targetShapeSigning (Fintype.card Index : ENNReal)⁻¹ reuse
+          (observedTargetShapeVector key payload target state) groups remaining := by
+  rw [logTracedMappedAdversaryImpl_run_map, tsum_probOutput_map_mul]
+  have hrun : (unloggedMappedAdversaryImpl key (.inr message)).run state.1 =
+      (fun result => (result.1.1, result.2)) <$> (simulateQ romImpl (signWithView key message)).run state.1 :=
+    (simulateQ_signWithView_fst_run key message state.1).symm
+  have heq := congrArg (fun computation : ProbComp (Option Signature × QueryCache HashSpec) =>
+    ∑' result, Pr[= result | computation] *
+      observedTargetShapeVector key payload target (result.2, state.2 ++ [⟨message, result.1⟩]) groups remaining) hrun
+  rw [tsum_probOutput_map_mul] at heq
+  exact heq.le.trans (expected_signWithView_targetShapeMoments_le_of_exactReuse key message state.1 state.2
+    payload target groups remaining hvalid hsigned reuse hreuse)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/ExtractFts.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/ExtractFts.lean
new file mode 100644
index 000000000..009b027a4
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/ExtractFts.lean
@@ -0,0 +1,140 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.Extract
+/-!
+# 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)
+
+theorem ftsLeafOfNat_val : ftsLeafOfNat leaf.val = leaf := by
+  ext
+  simp [ftsLeafOfNat, Nat.mod_eq_of_lt leaf.isLt]
+
+/-- 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/Fts/FewTimeConditionalCoverage.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeConditionalCoverage.lean
new file mode 100644
index 000000000..1d95a37da
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeConditionalCoverage.lean
@@ -0,0 +1,15 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FewTimeProbability
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+def CoveredFewTimeView {n : Nat} (views : Fin n → Option FewTimeView) (target : FewTimeView) : Prop :=
+  ∀ tree, ∃ slot view, views slot = some view ∧ view.1 = target.1 ∧ view.2 tree = target.2 tree
+
+noncomputable def signingSlotsAtIndex {n : Nat} (views : Fin n → Option FewTimeView) (index : Index) : Finset (Fin n) :=
+  Finset.univ.filter (fun slot => ∃ view, views slot = some view ∧ view.1 = index)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeFixedPrehit.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeFixedPrehit.lean
new file mode 100644
index 000000000..caf5e95d1
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeFixedPrehit.lean
@@ -0,0 +1,55 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FewTimeRace
+/-!
+# 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
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeFresh.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeFresh.lean
new file mode 100644
index 000000000..34aa58ca9
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeFresh.lean
@@ -0,0 +1,231 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FewTimeLoop
+import SphincsSecurity.Proof.Fts.FewTimePadding
+import SphincsSecurity.Proof.Fts.FewTimeSignerView
+/-!
+# 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
+
+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 × (IndexGroup → FtsLeaf)))) :
+                OracleComp OracleWorld (Option (Index × (IndexGroup → 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 × (IndexGroup → FtsLeaf)))) :
+              OracleComp OracleWorld (Option (Index × (IndexGroup → 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 × (IndexGroup → 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)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeFreshMass.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeFreshMass.lean
new file mode 100644
index 000000000..d90c077d5
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeFreshMass.lean
@@ -0,0 +1,125 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FewTimeTargetCompletion
+namespace SphincsSecurity.Concrete
+
+open OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+
+theorem probEvent_completeOption_eq {α β : Type} (comp : ProbComp α)
+    (selected : α → Option β) (fallback : ProbComp β) (P : β → Prop) :
+    Pr[P | comp >>= fun result => (selected result).elim fallback pure] =
+      Pr[fun result => ∃ value, selected result = some value ∧ P value | comp] +
+        Pr[fun result => selected result = none | comp] * Pr[P | fallback] := by
+  rw [probEvent_bind_eq_tsum,
+    probEvent_eq_tsum_ite comp (fun result => ∃ value, selected result = some value ∧ P value),
+    probEvent_eq_tsum_ite comp (fun result => selected result = none),
+    ← ENNReal.tsum_mul_right, ← ENNReal.tsum_add]
+  apply tsum_congr
+  intro result
+  cases selected result with
+  | none => simp [Option.elim]
+  | some value => simp [Option.elim, probEvent_pure, mul_ite]
+
+theorem probEvent_selectedOption_le_mass_mul {α β : Type} (comp : ProbComp α)
+    (selected : α → Option β) (fallback : ProbComp β) (P : β → Prop)
+    (hfail : Pr[⊥ | comp] = 0)
+    (hcomplete : Pr[P | comp >>= fun result => (selected result).elim fallback pure] ≤
+      Pr[P | fallback]) :
+    Pr[fun result => ∃ value, selected result = some value ∧ P value | comp] ≤
+      Pr[fun result => selected result ≠ none | comp] * Pr[P | fallback] := by
+  have hmass : Pr[fun result => selected result ≠ none | comp] +
+      Pr[fun result => selected result = none | comp] = 1 := by
+    simpa only [not_not, hfail, tsub_zero] using
+      probEvent_compl comp (fun result => selected result ≠ none)
+  apply ENNReal.le_of_add_le_add_right (a :=
+    Pr[fun result => selected result = none | comp] * Pr[P | fallback])
+    (ENNReal.mul_ne_top probEvent_ne_top probEvent_ne_top)
+  calc
+    _ = Pr[P | comp >>= fun result => (selected result).elim fallback pure] :=
+      (probEvent_completeOption_eq comp selected fallback P).symm
+    _ ≤ Pr[P | fallback] := hcomplete
+    _ = _ := by rw [← add_mul, hmass, one_mul]
+
+theorem probEvent_selectedOption_eq_mass_mul {α β : Type} (comp : ProbComp α)
+    (selected : α → Option β) (fallback : ProbComp β) (P : β → Prop)
+    (hfail : Pr[⊥ | comp] = 0) (hfallback : Pr[⊥ | fallback] = 0)
+    (hcomplete : ∀ Q : β → Prop,
+      Pr[Q | comp >>= fun result => (selected result).elim fallback pure] ≤ Pr[Q | fallback]) :
+    Pr[fun result => ∃ value, selected result = some value ∧ P value | comp] =
+      Pr[fun result => selected result ≠ none | comp] * Pr[P | fallback] := by
+  have hparts :
+      Pr[fun result => ∃ value, selected result = some value ∧ P value | comp] +
+        Pr[fun result => ∃ value, selected result = some value ∧ ¬ P value | comp] =
+      Pr[fun result => selected result ≠ none | comp] := by
+    simp only [probEvent_eq_tsum_ite, ← ENNReal.tsum_add]
+    apply tsum_congr
+    intro result
+    cases selected result with
+    | none => simp
+    | some value => by_cases hP : P value <;> simp [hP]
+  have hfallbackMass : Pr[P | fallback] + Pr[fun value => ¬ P value | fallback] = 1 := by
+    simpa only [hfallback, tsub_zero] using probEvent_compl fallback P
+  apply le_antisymm (probEvent_selectedOption_le_mass_mul comp selected fallback P hfail (hcomplete P))
+  apply ENNReal.le_of_add_le_add_right (a :=
+    Pr[fun result => selected result ≠ none | comp] * Pr[fun value => ¬ P value | fallback])
+    (ENNReal.mul_ne_top probEvent_ne_top probEvent_ne_top)
+  calc
+    _ = Pr[fun result => selected result ≠ none | comp] := by
+      rw [← mul_add, hfallbackMass, mul_one]
+    _ = _ := hparts.symm
+    _ ≤ _ := add_le_add le_rfl (probEvent_selectedOption_le_mass_mul comp selected fallback
+      (fun value => ¬ P value) hfail (hcomplete _))
+
+theorem freshSelectedLoopView?_satisfies_iff
+    (referenceCache : QueryCache HashSpec) (key : SecretKey) (message : Message)
+    (P : FewTimeView → Prop)
+    (result : Option (Randomness × Index × (IndexGroup → FtsLeaf)) × QueryCache HashSpec) :
+    (∃ view, freshSelectedLoopView? referenceCache key message result = some view ∧ P view) ↔
+      FreshSelectedView referenceCache key message P result := by
+  cases hresult : result.1 with
+  | none => simp [freshSelectedLoopView?, FreshSelectedView, hresult]
+  | some selected =>
+      rcases selected with ⟨randomness, index, leaves⟩
+      by_cases hfresh : referenceCache (tweakableHashInput key.parameter .message
+          (messageDigestPayload key.root message randomness)) = none
+      · simp [freshSelectedLoopView?, FreshSelectedView, hresult, hfresh]
+      · simp [freshSelectedLoopView?, FreshSelectedView, hresult, hfresh]
+
+theorem completeFreshSelectedLoopView_eq_elim
+    (referenceCache : QueryCache HashSpec) (key : SecretKey) (message : Message)
+    (result : Option (Randomness × Index × (IndexGroup → FtsLeaf)) × QueryCache HashSpec) :
+    completeFreshSelectedLoopView referenceCache key message result =
+      (freshSelectedLoopView? referenceCache key message result).elim
+        ($ᵗ FewTimeView) pure := by
+  unfold completeFreshSelectedLoopView
+  cases freshSelectedLoopView? referenceCache key message result <;> rfl
+
+theorem probEvent_signDigestLoop_freshSelected_eq_mass_mul_uniform
+    (attempts : Nat) (key : SecretKey) (message : Message)
+    (referenceCache workingCache : QueryCache HashSpec) (P : FewTimeView → Prop)
+    (hinvariant : OnlyRejectedNewMessageEntries referenceCache workingCache key message) :
+    Pr[FreshSelectedView referenceCache key message P |
+      (simulateQ romImpl (signDigestLoop attempts key message)).run workingCache] =
+      Pr[fun result => freshSelectedLoopView? referenceCache key message result ≠ none |
+        (simulateQ romImpl (signDigestLoop attempts key message)).run workingCache] *
+          Pr[P | ($ᵗ FewTimeView : ProbComp FewTimeView)] := by
+  have h := probEvent_selectedOption_eq_mass_mul
+    ((simulateQ romImpl (signDigestLoop attempts key message)).run workingCache)
+    (freshSelectedLoopView? referenceCache key message) ($ᵗ FewTimeView) P
+    (by simp) (by simp) (by
+      intro Q
+      simpa only [funext (completeFreshSelectedLoopView_eq_elim referenceCache key message)] using
+        (probEvent_completeFreshSelectedLoopView_le_uniform attempts key message
+          referenceCache workingCache Q hinvariant))
+  simpa only [freshSelectedLoopView?_satisfies_iff] using h
+
+noncomputable def freshDigestSelectionProbability
+    (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) : ENNReal :=
+  Pr[fun result => freshSelectedLoopView? cache key message result ≠ none |
+    (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run cache]
+
+theorem freshDigestSelectionProbability_le_one
+    (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) :
+    freshDigestSelectionProbability key message cache ≤ 1 := probEvent_le_one
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeLoop.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeLoop.lean
new file mode 100644
index 000000000..7ba62f425
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeLoop.lean
@@ -0,0 +1,42 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FewTimeUniform
+import SphincsSecurity.Proof.Fts.MessagePrehit
+import SphincsSecurity.Proof.Fts.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
+
+theorem signAttempt_result_of_cached (secretKey : SecretKey) (message : Message)
+    (randomness : Randomness) (beforeCache afterCache : QueryCache HashSpec)
+    (attempt : Option (Index × (IndexGroup → 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
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimePadding.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimePadding.lean
new file mode 100644
index 000000000..19490be7e
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimePadding.lean
@@ -0,0 +1,49 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FewTimeProbability
+/-!
+# 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 instSampleableTypeOfFintypeOfNonempty_sphincsSecurity_1 {α : Type} [Fintype α] [Nonempty α] : SampleableType α :=
+  SampleableType.ofFintype α
+
+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 _))]
+
+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]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimePrehit.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimePrehit.lean
new file mode 100644
index 000000000..89373dfc9
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimePrehit.lean
@@ -0,0 +1,126 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CacheSize
+import SphincsSecurity.Proof.Fts.FewTimeLoop
+import SphincsSecurity.Proof.Scheme.Secrets
+import SphincsSecurity.Proof.Reference.SigningTrace
+/-!
+# 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 instSampleableTypeRandomness_1 : 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)
+
+def Concrete.PrehitSelectedView (referenceCache : QueryCache HashSpec)
+    (secretKey : SecretKey) (message : Message) (P : Concrete.FewTimeView → Prop)
+    (result : Option (Randomness × Index × (IndexGroup → 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.signDigestLoop_initial_cached_result
+    (attempts : Nat) (secretKey : SecretKey) (message : Message)
+    (randomness : Randomness) (index : Index) (leaves : IndexGroup → 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 × (IndexGroup → FtsLeaf)))) :
+              OracleComp OracleWorld (Option (Index × (IndexGroup → 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)
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeProbability.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeProbability.lean
new file mode 100644
index 000000000..d2f2a5dc5
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeProbability.lean
@@ -0,0 +1,25 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FewTimeWitness
+/-!
+# 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)
+
+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]
+
+noncomputable local instance instSampleableTypeOfFintypeOfNonempty_sphincsSecurity {R : Type} [Fintype R] [Nonempty R] : SampleableType R :=
+  SampleableType.ofFintype R
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeRace.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeRace.lean
new file mode 100644
index 000000000..28ba8fcd3
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeRace.lean
@@ -0,0 +1,111 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FewTimeFresh
+import SphincsSecurity.Proof.Fts.FewTimePrehit
+/-!
+# 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 instSampleableTypeRandomness_2 : 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)
+
+noncomputable def Concrete.signDigestAttemptPrefix
+    (secretKey : SecretKey) (message : Message) (cache : QueryCache HashSpec) :
+    ProbComp (Randomness ×
+      (Option (Index × (IndexGroup → FtsLeaf)) × QueryCache HashSpec)) :=
+  ($ᵗ Randomness) >>= fun randomness =>
+    (simulateQ (randomOracle : QueryImpl HashSpec _)
+      (signAttempt secretKey message randomness)).run cache >>= fun result =>
+        pure (randomness, result)
+
+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 × (IndexGroup → FtsLeaf)) × QueryCache HashSpec)) : Prop :=
+  ∃ output, referenceCache
+    (tweakableHashInput secretKey.parameter .message
+      (messageDigestPayload secretKey.root message attempt.1)) = some output
+    ∧ signAttemptResultOfOutput output ≠ none
+    ∧ P (hashOutputFewTimeView output)
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeSignerView.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeSignerView.lean
new file mode 100644
index 000000000..b86a6df41
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeSignerView.lean
@@ -0,0 +1,88 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FewTimeUniform
+import SphincsSecurity.Proof.Scheme.NoMessage
+/-!
+# 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 : IndexGroup → 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]
+
+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 : IndexGroup → 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/Fts/FewTimeSource.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeSource.lean
new file mode 100644
index 000000000..4a77ec944
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeSource.lean
@@ -0,0 +1,32 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FewTimeLoop
+import SphincsSecurity.Proof.Reference.SigningTrace
+import SphincsSecurity.Proof.Scheme.Secrets
+/-!
+# 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 sequenceFin_some {alpha : Type} {count : Nat}
+    (values : Fin count → alpha) :
+    sequenceFin (m := Option) (fun position => some (values position)) = some values := by
+  induction count with
+  | zero =>
+      rw [sequenceFin]
+      congr
+      funext position
+      exact Fin.elim0 position
+  | succ count ih =>
+      rw [sequenceFin, 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
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeTargetCompletion.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeTargetCompletion.lean
new file mode 100644
index 000000000..fed19f81f
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeTargetCompletion.lean
@@ -0,0 +1,182 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FewTimeFresh
+/-!
+# 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 × (IndexGroup → 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 × (IndexGroup → 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 only [signDigestLoop, simulateQ_pure, StateT.run_pure, pure_bind, completeFreshSelectedLoopView,
+        freshSelectedLoopView?]
+      exact le_rfl
+  | 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 × (IndexGroup → FtsLeaf))))).run
+                workingCache >>= continuation) >>=
+                  completeFreshSelectedLoopView referenceCache secretKey message] ≤ _
+          have hcoordinates' :
+              𝒟[((simulateQ randomOracle
+                  (signAttempt secretKey message randomness :
+                    OracleComp HashSpec (Option (Index × (IndexGroup → 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 × (IndexGroup → FtsLeaf)))) :
+                  OracleComp OracleWorld (Option (Index × (IndexGroup → 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 only [signDigestLoopContinuation, hattemptResult, pure_bind, completeFreshSelectedLoopView,
+              freshSelectedLoopView?, if_neg hreference']
+            exact le_rfl
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeUniform.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeUniform.lean
new file mode 100644
index 000000000..e2cba0440
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeUniform.lean
@@ -0,0 +1,352 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FewTimeProbability
+import SphincsSecurity.Proof.Scheme.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 hashOutputFewTimeView (output : HashOutput) : FewTimeView :=
+  (digestIndex (truncateMessageDigest output),
+    fun tree => digestLeaves (truncateMessageDigest output) (ftsIndexOf tree))
+
+abbrev FullDigestView := Index × (IndexGroup → 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 : IndexGroup := ⟨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 lastIndexGroup)
+
+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 indexGroup_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
+
+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) lastIndexGroup),
+        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 × (IndexGroup → 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))
+        lastIndexGroup = 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 : IndexGroup → 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 : IndexGroup → 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 × (IndexGroup → 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/Fts/FewTimeWeightedOriginRace.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeWeightedOriginRace.lean
new file mode 100644
index 000000000..b5b772b3a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeWeightedOriginRace.lean
@@ -0,0 +1,42 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Statement
+
+/-! ## FewTimeParametricSignerRace -/
+
+namespace SphincsSecurity
+
+open OracleComp OracleSpec ENNReal
+
+theorem digestRaceSuccessRate_ne_zero_of_budget_lt
+    (budget : Nat) (hbudget : budget < 2 ^ randomnessBits) :
+    (1 - (budget : ENNReal) * ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹) *
+      ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ ≠ 0 := by
+  have hfraction : (budget : ENNReal) * ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ < 1 := by
+    rw [← div_eq_mul_inv, ENNReal.div_lt_iff (by left; positivity) (by left; finiteness), one_mul]
+    exact_mod_cast hbudget
+  exact mul_ne_zero (ne_of_gt (tsub_pos_iff_lt.mpr hfraction)) (ENNReal.inv_ne_zero.mpr (by finiteness))
+
+end SphincsSecurity
+
+namespace SphincsSecurity
+
+open OracleComp OracleSpec ENNReal
+
+namespace Concrete
+
+noncomputable def digestReuseWeight (q : Nat) : ℝ≥0∞ :=
+  ((2 ^ randomnessBits : Nat) : ℝ≥0∞)⁻¹ /
+    ((1 - ((q + digestAttemptLimit : Nat) : ℝ≥0∞) *
+      ((2 ^ randomnessBits : Nat) : ℝ≥0∞)⁻¹) *
+      ((2 ^ ftsTreeHeight : Nat) : ℝ≥0∞)⁻¹)
+
+theorem digestReuseWeight_ne_top (q : Nat) (hq : q ≤ 2 ^ 127) :
+    digestReuseWeight q ≠ ∞ := by
+  apply ENNReal.div_ne_top (by finiteness)
+  apply digestRaceSuccessRate_ne_zero_of_budget_lt
+  norm_num [digestAttemptLimit, randomnessBits] at *
+  omega
+
+end Concrete
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeWitness.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeWitness.lean
new file mode 100644
index 000000000..70bd72b2f
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FewTimeWitness.lean
@@ -0,0 +1,30 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Scheme.Replay
+/-!
+# 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 : Message) × SigningSpec.Range request
+theorem indexGroup_eq_ftsIndexOf_or_last (tree : IndexGroup) :
+    (∃ ftsTree : FtsTree, tree = ftsIndexOf ftsTree) ∨ tree = lastIndexGroup := 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
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FixedCertificateCoverage.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FixedCertificateCoverage.lean
new file mode 100644
index 000000000..ef570119b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FixedCertificateCoverage.lean
@@ -0,0 +1,92 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FixedProposalMoments
+import SphincsSecurity.Proof.Fts.TerminalCertificateCharge
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp ENNReal
+
+noncomputable def fixedCertificateGame (adversary : Adversary) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : SecretKey → CertificateStopRule) :
+    PMF (CertificateGameResult × List Index) :=
+  certificateTerminalGame adversary budget required
+    (fun key input state length record =>
+      proposalPrefixStop input state length record || stopAfter key input state length record)
+    false fixedProposalLength
+
+theorem uniformWordAverage_eq_independent {α : Type} [SampleableType α] [Fintype α] [Nonempty α]
+    (steps : Nat) (payoff : List α → ENNReal) :
+    uniformWordAverage steps payoff =
+      ∑' word, Pr[= word | independentProposalWord (PMF.uniformOfFintype α) steps] * payoff word := by
+  simp only [uniformWordAverage, probOutput_def, evalDist_sampleUniformProposalWord, PMF.evalDist_eq]
+
+theorem expected_fixedCertificateGame_count_le_message_excess (adversary : Adversary)
+    (q : Nat) (required : Finset FtsTree) (stopAfter : SecretKey → CertificateStopRule)
+    (hbudget : q ≤ 2 ^ 127) (hbound : HasHashQueryBound scheme adversary q) (baseline : ENNReal) :
+    (∑' result, Pr[= result | fixedCertificateGame adversary q required stopAfter] *
+      certificateBankCount result.1.2.2.2.bank) ≤
+        baseline * (∑' result, Pr[= result | fixedCertificateGame adversary q required stopAfter] *
+          result.1.2.2.2.messageCalls) +
+          (q : ENNReal) * uniformWordAverage fixedProposalLength
+            (fun word => terminalCertificatePrice required word - baseline) := by
+  let law := fixedCertificateGame adversary q required stopAfter
+  have hmass :
+      (∑' result, Pr[= result | law] * result.1.2.2.2.creationMass) ≤
+        ∑' result, Pr[= result | law] * result.1.2.2.2.messageCalls := by
+    change (∑' result, Pr[= result | certificateTerminalGame adversary q required _ false fixedProposalLength] *
+      result.1.2.2.2.creationMass) ≤ _
+    rw [expected_certificateTerminalGame_project adversary q required _ false fixedProposalLength
+      (fun result => result.2.2.2.creationMass)]
+    change _ ≤ ∑' result, Pr[= result | certificateTerminalGame adversary q required _ false fixedProposalLength] *
+      (result.1.2.2.2.messageCalls : ENNReal)
+    rw [expected_certificateTerminalGame_project adversary q required _ false fixedProposalLength
+      (fun result => (result.2.2.2.messageCalls : ENNReal))]
+    exact expected_certificateGame_creationMass_le_messageCalls adversary q required _ false
+  calc
+    _ ≤ ∑' result, Pr[= result | law] *
+        (result.1.2.2.2.creationMass * terminalCertificatePrice required result.2) := by
+      simpa [fixedCertificateGame, law, fixedProposalLength] using
+        expected_certificateTerminalGame_count_le_mass_price adversary q fixedProposalLength required stopAfter hbudget
+    _ ≤ ∑' result, Pr[= result | law] *
+        (result.1.2.2.2.creationMass * (baseline + (terminalCertificatePrice required result.2 - baseline))) := by
+      apply ENNReal.tsum_le_tsum
+      intro result
+      exact mul_le_mul' le_rfl (mul_le_mul' le_rfl le_add_tsub)
+    _ = baseline * (∑' result, Pr[= result | law] * result.1.2.2.2.creationMass) +
+        ∑' result, Pr[= result | law] *
+          (result.1.2.2.2.creationMass * (terminalCertificatePrice required result.2 - baseline)) := by
+      simp_rw [mul_add, ENNReal.tsum_add]
+      congr 1
+      calc
+        _ = ∑' result, baseline * (Pr[= result | law] * result.1.2.2.2.creationMass) := by
+          apply tsum_congr
+          intro result
+          ring
+        _ = _ := ENNReal.tsum_mul_left
+    _ ≤ _ := by
+      apply add_le_add (mul_le_mul' le_rfl hmass)
+      rw [uniformWordAverage_eq_independent]
+      exact expected_certificateTerminalGame_mass_payoff_le adversary q required _ false fixedProposalLength hbound _
+
+private theorem terminalCertificatePrice_factor (required : Finset FtsTree) (word : List Index) :
+    terminalCertificatePrice required word =
+      ((((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ * (Fintype.card Index : ENNReal)⁻¹) *
+        targetCertificateScale required) * proposalPowerSum required.card word := by
+  unfold terminalCertificatePrice proposalPowerSum
+  ring
+
+theorem terminalCertificatePrice_full (word : List Index) :
+    terminalCertificatePrice Finset.univ word = (2 ^ 128 : ENNReal)⁻¹ * fixedFullProposalPrice word := by
+  have htrees : Fintype.card FtsTree = 14 := Fintype.card_fin _
+  have hindex : Fintype.card Index = 2 ^ 26 := Fintype.card_fin _
+  have hleaf : Fintype.card FtsLeaf = 2 ^ 10 := Fintype.card_fin _
+  rw [terminalCertificatePrice_factor, Finset.card_univ, htrees]
+  have hcoefficient :
+      ((((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ * (Fintype.card Index : ENNReal)⁻¹) *
+        targetCertificateScale Finset.univ) = (2 ^ 128 : ENNReal)⁻¹ * (2 ^ 48 : ENNReal)⁻¹ := by
+    unfold targetCertificateScale
+    rw [Finset.card_univ, htrees, hindex, hleaf]
+    apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp
+    norm_num [ftsTreeHeight, ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_pow]
+  rw [hcoefficient, fixedFullProposalPrice, mul_assoc]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FixedProposalMoments.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FixedProposalMoments.lean
new file mode 100644
index 000000000..cbd677421
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FixedProposalMoments.lean
@@ -0,0 +1,61 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Base.StirlingMomentBounds
+import SphincsSecurity.Proof.Fts.UniformProposalVariance
+namespace SphincsSecurity.Concrete
+
+open ENNReal
+
+def fixedProposalLength : Nat := 25313293
+
+noncomputable def fixedFullProposalPrice (word : List Index) : ENNReal :=
+  (2 ^ 48 : ENNReal)⁻¹ * proposalPowerSum 14 word
+
+theorem fixedProposalLength_rate_le :
+    (fixedProposalLength : ENNReal) * (Fintype.card Index : ENNReal)⁻¹ ≤ 19 / 50 := by
+  have hcard : Fintype.card Index = 2 ^ 26 := Fintype.card_fin _
+  rw [hcard]
+  apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp
+  norm_num [fixedProposalLength, ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_div]
+
+theorem fixedFullProposalPrice_ne_top (word : List Index) : fixedFullProposalPrice word ≠ ⊤ := by
+  apply ENNReal.mul_ne_top (by finiteness)
+  apply ENNReal.sum_ne_top.mpr
+  intro index _
+  finiteness
+
+theorem uniformWordAverage_fixedFull_mean_le :
+    uniformWordAverage fixedProposalLength fixedFullProposalPrice ≤ 1 / 5 := by
+  unfold fixedFullProposalPrice
+  rw [uniformWordAverage_mul_left]
+  have h := mul_le_mul' (a := (2 ^ 48 : ENNReal)⁻¹) le_rfl
+    (uniformWordAverage_powerSum_le (α := Index) fixedProposalLength 14 (19 / 50) fixedProposalLength_rate_le)
+  have hcard : Fintype.card Index = 2 ^ 26 := Fintype.card_fin _
+  rw [hcard] at h
+  apply h.trans
+  calc
+    _ = (2 ^ 26 : ENNReal) * (2 ^ 48 : ENNReal)⁻¹ * stirlingPowerMoment (19 / 50) 14 := by
+      push_cast
+      ring
+    _ ≤ _ := stirlingPowerMoment_full_mean_le
+
+theorem uniformWordAverage_fixedFull_secondMoment_le :
+    uniformWordAverage fixedProposalLength (fun word => fixedFullProposalPrice word ^ 2) ≤
+      uniformWordAverage fixedProposalLength fixedFullProposalPrice ^ 2 + 13 / 25000 := by
+  unfold fixedFullProposalPrice
+  simp only [mul_pow, uniformWordAverage_mul_left]
+  have h := mul_le_mul' (a := ((2 ^ 48 : ENNReal)⁻¹) ^ 2) le_rfl
+    (uniformWordAverage_powerSum_square_le (α := Index) fixedProposalLength 14 (19 / 50) fixedProposalLength_rate_le)
+  have hcard : Fintype.card Index = 2 ^ 26 := Fintype.card_fin _
+  rw [hcard, mul_add] at h
+  apply h.trans
+  apply add_le_add le_rfl
+  have hscale : ((2 ^ 48 : ENNReal)⁻¹) ^ 2 = (2 ^ 96 : ENNReal)⁻¹ := by
+    rw [← ENNReal.inv_pow, ← pow_mul]
+  rw [hscale]
+  calc
+    _ = (2 ^ 26 : ENNReal) * (2 ^ 96 : ENNReal)⁻¹ * stirlingPowerMoment (19 / 50) 28 := by
+      push_cast
+      ring
+    _ ≤ _ := stirlingPowerMoment_full_variance_le
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FreshDigestHazard.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FreshDigestHazard.lean
new file mode 100644
index 000000000..d3346b48b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FreshDigestHazard.lean
@@ -0,0 +1,50 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.DigestAttemptExpectation
+import SphincsSecurity.Proof.Fts.FewTimeTargetCompletion
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] signAttempt signDigestAttemptPrefix signDigestLoop
+
+def FreshDigestAttempt (reference : QueryCache HashSpec) (key : SecretKey) (message : Message)
+    (result : DigestAttemptResult) : Prop :=
+  reference (tweakableHashInput key.parameter .message (messageDigestPayload key.root message result.1)) = none ∧
+    result.2.1 ≠ none
+
+private theorem probEvent_digestContinuation_fresh_eq
+    (attempts : Nat) (key : SecretKey) (message : Message)
+    (reference : QueryCache HashSpec) (result : DigestAttemptResult) :
+    Pr[fun selected => freshSelectedLoopView? reference key message selected ≠ none |
+      signDigestLoopContinuation attempts key message result.1 result.2] =
+      (if FreshDigestAttempt reference key message result then 1 else 0) +
+        if result.2.1 = none then
+          Pr[fun selected => freshSelectedLoopView? reference key message selected ≠ none |
+            (simulateQ romImpl (signDigestLoop attempts key message)).run result.2.2] else 0 := by
+  cases hr : result.2.1 with
+  | none => simp only [signDigestLoopContinuation, FreshDigestAttempt, hr, ne_eq, not_true_eq_false,
+      and_false, if_false, if_true, zero_add]
+  | some selected =>
+      obtain ⟨index, leaves⟩ := selected
+      by_cases hc : reference (tweakableHashInput key.parameter .message
+          (messageDigestPayload key.root message result.1)) = none
+      · simp [signDigestLoopContinuation, FreshDigestAttempt, freshSelectedLoopView?, hr, hc]
+      · simp [signDigestLoopContinuation, FreshDigestAttempt, freshSelectedLoopView?, hr, hc]
+
+theorem probEvent_signDigestLoop_fresh_recurrence
+    (attempts : Nat) (key : SecretKey) (message : Message) (reference cache : QueryCache HashSpec) :
+    Pr[fun result => freshSelectedLoopView? reference key message result ≠ none |
+      (simulateQ romImpl (signDigestLoop (attempts + 1) key message)).run cache] =
+      Pr[FreshDigestAttempt reference key message | signDigestAttemptPrefix key message cache] +
+        ∑' result, Pr[= result | signDigestAttemptPrefix key message cache] *
+          if result.2.1 = none then
+            Pr[fun selected => freshSelectedLoopView? reference key message selected ≠ none |
+              (simulateQ romImpl (signDigestLoop attempts key message)).run result.2.2] else 0 := by
+  rw [signDigestLoop_run_succ_eq_attemptPrefix, probEvent_bind_eq_tsum,
+    probEvent_eq_tsum_ite, ← ENNReal.tsum_add]
+  apply tsum_congr
+  intro result
+  rw [probEvent_digestContinuation_fresh_eq]
+  split_ifs <;> ring
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FreshTargetEnvelope.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FreshTargetEnvelope.lean
new file mode 100644
index 000000000..066fc9262
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FreshTargetEnvelope.lean
@@ -0,0 +1,53 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.ConcreteTargetShapeQuery
+import SphincsSecurity.Proof.Fts.FreshTargetShapeAverage
+import SphincsSecurity.Proof.Fts.TargetIndexEnvelope
+import SphincsSecurity.Proof.Fts.TargetShapeExpectation
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+set_option backward.isDefEq.respectTransparency false
+
+theorem expected_fresh_targetShapeEnvelope (key : SecretKey) (cache : QueryCache HashSpec) (log : QueryLog SigningSpec)
+    (payload : HashInput) (hfresh : cache (tweakableHashInput key.parameter .message payload) = none)
+    (hsigned : SigningDigestsCached key.parameter cache key.root log) (uniform reuse arrival : ENNReal) (queries signings : Nat)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining) :
+    (∑' target, Pr[= target | ($ᵗ FewTimeView : ProbComp FewTimeView)] *
+      targetShapeEnvelope uniform reuse arrival queries signings (targetShapeMoments key cache log payload target) groups remaining) =
+        (Fintype.card Index : ENNReal)⁻¹ *
+          targetIndexEnvelope uniform reuse arrival queries signings (targetIndexMoments key cache log) groups.card remaining.card := by
+  rw [targetShapeEnvelope_expected]
+  have heq : ∀ G R, TargetShapeValid G R →
+      (∑' target, Pr[= target | ($ᵗ FewTimeView : ProbComp FewTimeView)] * targetShapeMoments key cache log payload target G R) =
+        (Fintype.card Index : ENNReal)⁻¹ * liftTargetIndexVector (targetIndexMoments key cache log) G R :=
+    fun G R hv => expected_fresh_targetShapeMoments key cache log payload hfresh hsigned G R hv
+  rw [targetShapeEnvelope_congr uniform reuse arrival queries signings heq groups remaining hvalid,
+    targetShapeEnvelope_mul, targetShapeEnvelope_lift uniform reuse arrival queries signings _ groups remaining hvalid]
+
+theorem targetShapeMoments_cacheQuery_self_vector (key : SecretKey) (before : QueryCache HashSpec) (log : QueryLog SigningSpec)
+    (payload : HashInput) (target : FewTimeView) (output : HashOutput)
+    (hfresh : before (tweakableHashInput key.parameter .message payload) = none)
+    (hsigned : SigningDigestsCached key.parameter before key.root log) :
+    targetShapeMoments key (before.cacheQuery (tweakableHashInput key.parameter .message payload) output) log payload target =
+      targetShapeMoments key before log payload target := by
+  funext groups remaining
+  exact targetShapeMoments_cacheQuery_unchanged key before log payload target groups remaining _ output hfresh hsigned (Or.inr rfl)
+
+theorem expected_cacheQuery_freshTargetEnvelope (key : SecretKey) (before : QueryCache HashSpec) (log : QueryLog SigningSpec)
+    (payload : HashInput) (hfresh : before (tweakableHashInput key.parameter .message payload) = none)
+    (hsigned : SigningDigestsCached key.parameter before key.root log) (uniform reuse arrival : ENNReal) (queries signings : Nat)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining) :
+    (∑' output, Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] *
+      (if Admissible (truncateMessageDigest output) then
+        targetShapeEnvelope uniform reuse arrival queries signings
+          (targetShapeMoments key (before.cacheQuery (tweakableHashInput key.parameter .message payload) output) log payload (hashOutputFewTimeView output))
+          groups remaining else 0)) =
+      (((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ * (Fintype.card Index : ENNReal)⁻¹) *
+        targetIndexEnvelope uniform reuse arrival queries signings (targetIndexMoments key before log) groups.card remaining.card := by
+  simp only [targetShapeMoments_cacheQuery_self_vector key before log payload _ _ hfresh hsigned]
+  rw [expected_uniformHashOutput_admissible_weight
+    (fun target => targetShapeEnvelope uniform reuse arrival queries signings (targetShapeMoments key before log payload target) groups remaining),
+    expected_fresh_targetShapeEnvelope key before log payload hfresh hsigned uniform reuse arrival queries signings groups remaining hvalid]
+  exact (mul_assoc _ _ _).symm
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FreshTargetPayload.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FreshTargetPayload.lean
new file mode 100644
index 000000000..7fdd1f348
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FreshTargetPayload.lean
@@ -0,0 +1,37 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CachedTargetIncrement
+import SphincsSecurity.Proof.Fts.ConcreteTargetShapeSigning
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem cacheMessageWeight_exclude_fresh (parameter : PublicParameter) (cache : QueryCache HashSpec)
+    (targetInput : HashInput) (hfresh : cache targetInput = none) (weight : FewTimeView → ENNReal) :
+    cacheMessageWeight parameter (fun input source => if input = targetInput then 0 else weight source) cache =
+      cacheMessageWeight parameter (fun _ source => weight source) cache := by
+  unfold cacheMessageWeight
+  apply tsum_congr
+  intro input
+  by_cases heq : input = targetInput
+  · subst input
+    simp only [cacheMessageEntryWeight, hfresh]
+  · unfold cacheMessageEntryWeight
+    cases cache input <;> simp only [heq, if_false]
+
+theorem targetShapeMoments_fresh_payload_eq (key : SecretKey) (cache : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (first second : HashInput)
+    (hfirst : cache (tweakableHashInput key.parameter .message first) = none)
+    (hsecond : cache (tweakableHashInput key.parameter .message second) = none)
+    (hsigned : SigningDigestsCached key.parameter cache key.root log) (target : FewTimeView) :
+    targetShapeMoments key cache log first target = targetShapeMoments key cache log second target := by
+  funext groups remaining
+  unfold targetShapeMoments normalizedTargetLogProduct normalizedTargetLogMatch
+  simp only [normalizedCachedTargetSubsetMatch_eq_weight,
+    cacheMessageWeight_exclude_fresh key.parameter cache _ hfirst,
+    cacheMessageWeight_exclude_fresh key.parameter cache _ hsecond,
+    eligibleSigningViews_fresh_eq_observed key.parameter key.root cache log first hfirst hsigned,
+    eligibleSigningViews_fresh_eq_observed key.parameter key.root cache log second hsecond hsigned]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FreshTargetShapeAverage.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FreshTargetShapeAverage.lean
new file mode 100644
index 000000000..d5e224f43
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FreshTargetShapeAverage.lean
@@ -0,0 +1,37 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CacheIndexMultiplicity
+import SphincsSecurity.Proof.Fts.CachedTargetIncrement
+import SphincsSecurity.Proof.Fts.TargetShapeBlocks
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem excludedCacheIndexCount_fresh (parameter : PublicParameter) (cache : QueryCache HashSpec) (targetInput : HashInput)
+    (hfresh : cache targetInput = none) (index : Index) :
+    excludedCacheIndexCount parameter cache targetInput index = cachedIndexMultiplicity parameter cache index := by
+  unfold excludedCacheIndexCount cachedIndexMultiplicity cacheMessageWeight
+  apply tsum_congr
+  intro input
+  by_cases heq : input = targetInput
+  · subst input
+    simp only [cacheMessageEntryWeight, hfresh]
+  · unfold cacheMessageEntryWeight
+    cases cache input <;> simp only [heq, if_false]
+
+noncomputable def targetIndexMoments (key : SecretKey) (cache : QueryCache HashSpec) (log : QueryLog SigningSpec) (power degree : Nat) : ENNReal :=
+  ∑ index : Index, cachedIndexMultiplicity key.parameter cache index ^ power *
+    ((signingSlotsAtIndex (observedOptionalSigningViews (FtsProbeSimulation.messageAnswers key.parameter cache) key.root log) index).card : ENNReal) ^ degree
+
+theorem expected_fresh_targetShapeMoments (key : SecretKey) (cache : QueryCache HashSpec) (log : QueryLog SigningSpec)
+    (payload : HashInput) (hfresh : cache (tweakableHashInput key.parameter .message payload) = none)
+    (hsigned : SigningDigestsCached key.parameter cache key.root log)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining) :
+    (∑' target, Pr[= target | ($ᵗ FewTimeView : ProbComp FewTimeView)] * targetShapeMoments key cache log payload target groups remaining) =
+      (Fintype.card Index : ENNReal)⁻¹ * targetIndexMoments key cache log groups.card remaining.card := by
+  rw [expected_targetShapeMoments key cache log payload groups remaining hvalid]
+  simp only [excludedCacheIndexCount_fresh key.parameter cache _ hfresh,
+    eligibleSigningViews_fresh_eq_observed key.parameter key.root cache log payload hfresh hsigned, targetIndexMoments]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FtsProbeAdversary.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FtsProbeAdversary.lean
new file mode 100644
index 000000000..306be41bc
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FtsProbeAdversary.lean
@@ -0,0 +1,61 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Reference.DirectQueryBudget
+import SphincsSecurity.Proof.Fts.FtsProbeGame
+namespace SphincsSecurity.Concrete.FtsProbeSimulation
+
+open OracleComp OracleSpec
+
+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 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)
+
+end SphincsSecurity.Concrete.FtsProbeSimulation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FtsProbeGame.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FtsProbeGame.lean
new file mode 100644
index 000000000..b955430a0
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FtsProbeGame.lean
@@ -0,0 +1,34 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FtsProbeSimulation
+namespace SphincsSecurity.Concrete.FtsProbeSimulation
+
+open OracleComp OracleSpec
+
+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
+
+end SphincsSecurity.Concrete.FtsProbeSimulation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FtsProbeOrigin.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FtsProbeOrigin.lean
new file mode 100644
index 000000000..7a53552e1
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FtsProbeOrigin.lean
@@ -0,0 +1,27 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FtsProbeAdversary
+namespace SphincsSecurity.AdaptiveRevealProbe
+
+open OracleComp OracleSpec
+
+variable {Coordinate : Type} [Fintype Coordinate] [DecidableEq Coordinate]
+
+end SphincsSecurity.AdaptiveRevealProbe
+
+namespace SphincsSecurity.Concrete.FtsProbeSimulation
+
+open OracleComp OracleSpec
+
+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]
+
+end SphincsSecurity.Concrete.FtsProbeSimulation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FtsProbeProbability.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FtsProbeProbability.lean
new file mode 100644
index 000000000..464e7c3ef
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FtsProbeProbability.lean
@@ -0,0 +1,36 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FtsProbeAdversary
+namespace SphincsSecurity.Concrete.FtsProbeSimulation
+
+open OracleComp OracleSpec
+open OracleComp.ProgramLogic.Relational
+
+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]
+
+end SphincsSecurity.Concrete.FtsProbeSimulation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FtsProbeSampling.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FtsProbeSampling.lean
new file mode 100644
index 000000000..5d6beb008
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FtsProbeSampling.lean
@@ -0,0 +1,65 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FtsProbeProbability
+import SphincsSecurity.Proof.Fts.FewTimeSource
+import SphincsSecurity.Proof.Fts.FtsProbeOrigin
+namespace SphincsSecurity
+
+open OracleComp OracleSpec ENNReal
+open OracleComp.ProgramLogic.Relational
+
+namespace Concrete.FtsProbeSimulation
+
+attribute [local semireducible] sampleFtsSecrets
+
+abbrev RetainedRestResult := (Forgery × QueryLog SigningSpec) × Bool
+
+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_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
+
+end Concrete.FtsProbeSimulation
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FtsProbeSimulation.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FtsProbeSimulation.lean
new file mode 100644
index 000000000..d3d822f5a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FtsProbeSimulation.lean
@@ -0,0 +1,65 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FewTimeSignerView
+import SphincsSecurity.Proof.Ots.SecretProbe
+/-!
+# 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 instNonemptyCoordinate : Nonempty Coordinate :=
+  ⟨(⟨0, by norm_num [totalHeight]⟩,
+    ⟨0, by norm_num [ftsTrees]⟩,
+    ⟨0, by norm_num [ftsTreeHeight]⟩)⟩
+
+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
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FtsProbeVerifierSource.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FtsProbeVerifierSource.lean
new file mode 100644
index 000000000..f1d80c7a4
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FtsProbeVerifierSource.lean
@@ -0,0 +1,64 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FtsProbeAdversary
+
+/-! ## FtsProbeStablePrefixQueries -/
+
+namespace SphincsSecurity.Concrete.FtsProbeSimulation
+
+open _root_.OracleComp OracleSpec ENNReal
+
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def liftHashSource (computation : OracleComp HashSpec α) : OracleComp (OracleWorld + SigningSpec) α :=
+  simulateQ (fun input => (liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) (.inl (.inr input))) :
+    OracleComp (OracleWorld + SigningSpec) HashOutput)) computation
+
+theorem liftHashSource_query_bind (input : HashInput) (next : HashOutput → OracleComp HashSpec α) :
+    liftHashSource ((liftM (OracleSpec.query (spec := HashSpec) input) : OracleComp HashSpec HashOutput) >>= next) =
+      ((liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) (.inl (.inr input))) :
+        OracleComp (OracleWorld + SigningSpec) HashOutput) >>= fun output => liftHashSource (next output)) := by
+  rw [liftHashSource, simulateQ_bind, simulateQ_spec_query]
+  rfl
+
+end SphincsSecurity.Concrete.FtsProbeSimulation
+
+namespace SphincsSecurity.Concrete.FtsProbeSimulation
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+theorem liftOracleWorldLeft_query_bind
+    (input : OracleWorld.Domain) (next : OracleWorld.Range input → OracleComp OracleWorld α) :
+    liftOracleWorldLeft (OracleSpec.query input >>= next) =
+      ((liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) (.inl input)) :
+        OracleComp (OracleWorld + SigningSpec) _) >>= fun reply => liftOracleWorldLeft (next reply)) := by
+  letI directLift : MonadLift (OracleQuery OracleWorld) (OracleQuery (OracleWorld + SigningSpec)) :=
+    (OracleQuery.subSpec_add_left (spec₁ := OracleWorld) (spec₂ := SigningSpec)).toMonadLift
+  unfold liftOracleWorldLeft
+  rw [liftM_bind]
+  rfl
+
+theorem liftHashSource_eq_liftOracleWorldLeft (computation : OracleComp HashSpec α) :
+    liftHashSource computation = liftOracleWorldLeft (liftM computation : OracleComp OracleWorld α) := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => rfl
+  | query_bind input next ih =>
+      have hworld : (liftM ((liftM (OracleSpec.query (spec := HashSpec) input) : OracleComp HashSpec HashOutput) >>= next) :
+          OracleComp OracleWorld α) =
+          ((liftM (OracleSpec.query (spec := OracleWorld) (.inr input)) : OracleComp OracleWorld HashOutput) >>=
+            fun reply => liftM (next reply)) := by
+        letI directLift : MonadLift (OracleQuery HashSpec) (OracleQuery OracleWorld) :=
+          (OracleQuery.subSpec_add_right (spec₁ := unifSpec) (spec₂ := HashSpec)).toMonadLift
+        rw [liftM_bind]
+        rfl
+      rw [liftHashSource_query_bind, hworld, liftOracleWorldLeft_query_bind]
+      exact bind_congr ih
+
+theorem liftOracleWorldLeft_scheme_verify (publicKey : PublicKey) (message : Message) (signature : Signature) :
+    liftOracleWorldLeft (scheme.verify publicKey message signature) =
+      liftHashSource (verify (m := OracleComp HashSpec) publicKey message signature) := by
+  rw [liftHashSource_eq_liftOracleWorldLeft]
+  rfl
+
+end SphincsSecurity.Concrete.FtsProbeSimulation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FtsVerifierWitness.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FtsVerifierWitness.lean
new file mode 100644
index 000000000..e47337586
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FtsVerifierWitness.lean
@@ -0,0 +1,111 @@
+import SphincsSecurity.Proof.Reference.VerifierTraceDescent
+import SphincsSecurity.Proof.Hypertree.TreeFoldBound
+import SphincsSecurity.Proof.Hypertree.GraphPayloadInputs
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec OtsContactTrace
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalPayloadInputs
+
+def QueriedOutputMatch (f : QueryImpl HashSpec Id) (key : SecretKey) (position : Position) (trace : Trace) : Prop :=
+  position.TreeBound ∧ ∃ payload, payload ∈ canonicalPayloadInputs ∧
+    (tweakableHashInput key.parameter position.domain payload, f (tweakableHashInput key.parameter position.domain payload)) ∈ trace.toList ∧
+    payload ≠ honestPayload f key.parameter key.otsSecret key.ftsSecret position ∧
+    truncateHash (f (tweakableHashInput key.parameter position.domain payload)) = honestValue f key.parameter key.otsSecret key.ftsSecret position
+
+namespace FtsVerifierWitness
+
+variable (f : QueryImpl HashSpec Id) (key : SecretKey) (index : Index)
+
+def AtIndex : Position → Prop
+  | .ftsLeaf actual _ _ | .ftsNode actual _ _ _ | .ftsRoots actual => actual = index
+  | _ => False
+
+def Exception (trace : Trace) : Prop := ∃ position, AtIndex index position ∧ QueriedOutputMatch f key position trace
+
+def Opening (leaves : IndexGroup → FtsLeaf) (secrets : FtsTree → Digest) (paths : FtsTree → Fin ftsTreeHeight → Digest) : Prop :=
+  ∀ tree, secrets tree = key.ftsSecret index tree (leaves (ftsIndexOf tree)) ∧
+    ∀ level (hlevel : level < ftsTreeHeight), paths tree ⟨level, hlevel⟩ =
+      honestFtsNode f key.parameter index tree (key.ftsSecret index tree) level (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level) 1)
+
+def TrueSecretQuery (tree : FtsTree) (leaf : FtsLeaf) (trace : Trace) : Prop :=
+  let input := tweakableHashInput key.parameter (.ftsLeaf index tree leaf) (digestBytes (key.ftsSecret index tree leaf))
+  (input, f input) ∈ trace.toList
+
+theorem tree_reference (leaves : IndexGroup → FtsLeaf) (secrets : FtsTree → Digest) (paths : FtsTree → Fin ftsTreeHeight → Digest)
+    (trace : Trace) (hclean : ¬Exception f key index trace) (tree : FtsTree)
+    (hfold : ftsFoldValue f key.parameter index tree (leaves (ftsIndexOf tree)) (paths tree)
+      (truncateHash (f (tweakableHashInput key.parameter (.ftsLeaf index tree (leaves (ftsIndexOf tree))) (digestBytes (secrets tree))))) ftsTreeHeight =
+        honestFtsNode f key.parameter index tree (key.ftsSecret index tree) ftsTreeHeight 0)
+    (hrun : ContainsRun f trace (ftsRecover key.parameter index leaves secrets paths)) :
+    secrets tree = key.ftsSecret index tree (leaves (ftsIndexOf tree)) ∧
+      ∀ level (hlevel : level < ftsTreeHeight), paths tree ⟨level, hlevel⟩ =
+        honestFtsNode f key.parameter index tree (key.ftsSecret index tree) level (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level) 1) := by
+  let leaf := leaves (ftsIndexOf tree)
+  let value := truncateHash (f (tweakableHashInput key.parameter (.ftsLeaf index tree leaf) (digestBytes (secrets tree))))
+  have hroot : leaf.val / 2 ^ ftsTreeHeight = 0 := Nat.div_eq_of_lt leaf.isLt
+  rcases ftsFold_extract f key.parameter index tree (key.ftsSecret index tree) leaf (paths tree) value ftsTreeHeight (le_refl _)
+      (by simpa only [leaf, value, hroot] using hfold) with ⟨hv, hp⟩ | ⟨level, hl, hh⟩
+  · rcases ftsLeaf_extract f key.parameter index tree (key.ftsSecret index tree) leaf (secrets tree) hv with hs | hh
+    · refine ⟨hs, ?_⟩
+      intro level hl
+      simpa only [ftsSibling, dif_pos hl, leaf] using hp level hl
+    · apply False.elim
+      apply hclean
+      refine ⟨.ftsLeaf index tree leaf, rfl, trivial, digestBytes (secrets tree), digestBytes_mem_canonicalPayloadInputs _,
+        hrun _ (ftsRecover_leaf_query_mem f key.parameter index leaves secrets paths tree), ?_, ?_⟩
+      · exact fun he => hh.1 (digestBytes_injective he)
+      · simpa only [Position.domain, honestValue_ftsLeaf] using hh.2
+  · have hn : leaf.val / 2 ^ (level + 1) < 2 ^ ftsTreeHeight := (Nat.div_le_self _ _).trans_lt leaf.isLt
+    apply False.elim
+    apply hclean
+    refine ⟨.ftsNode index tree ⟨level, hl⟩ ⟨_, hn⟩, rfl,
+      fold_node_bound ftsTreeHeight level leaf.val hl leaf.isLt, ftsFoldPayload f key.parameter index tree leaf (paths tree) value level,
+      orderedPayload_mem_canonicalPayloadInputs _ _ _,
+      hrun _ (ftsRecover_fold_query_mem f key.parameter index leaves secrets paths tree level hl), hh.1, ?_⟩
+    simpa only [Position.domain, honestValue_ftsNode] using hh.2
+
+theorem recover_reference (leaves : IndexGroup → FtsLeaf) (secrets : FtsTree → Digest) (paths : FtsTree → Fin ftsTreeHeight → Digest)
+    (trace : Trace) (hclean : ¬Exception f key index trace)
+    (hrecover : evalWithAnswerFn f (ftsRecover key.parameter index leaves secrets paths) = honestFtsKey f key.parameter index (key.ftsSecret index))
+    (hrun : ContainsRun f trace (ftsRecover key.parameter index leaves secrets paths)) : Opening f key index leaves secrets paths := by
+  let roots : FtsTree → Digest := fun tree => evalWithAnswerFn f
+    (ftsFold key.parameter index tree (leaves (ftsIndexOf tree)) (paths tree) ftsTreeHeight
+      (evalWithAnswerFn f (ftsLeafHash key.parameter index tree (leaves (ftsIndexOf tree)) (secrets tree))))
+  by_cases hp : ftsRootsPayload roots = honestPayload f key.parameter key.otsSecret key.ftsSecret (.ftsRoots index)
+  · have hr : roots = fun tree => honestFtsNode f key.parameter index tree (key.ftsSecret index tree) ftsTreeHeight 0 := by
+      apply TargetSum.ftsRootsPayload_injective
+      exact hp
+    intro tree
+    apply tree_reference f key index leaves secrets paths trace hclean tree _ hrun
+    simpa only [roots, evalWithAnswerFn_bind, ftsLeafHash, eval_tweakableHash, ftsFoldValue] using congrFun hr tree
+  · apply False.elim
+    apply hclean
+    refine ⟨.ftsRoots index, rfl, trivial, ftsRootsPayload roots, ftsRootsPayload_mem_canonicalPayloadInputs _, ?_, hp, ?_⟩
+    · exact hrun _ (ftsRecover_roots_query_mem f key.parameter index leaves secrets paths)
+    · rw [honestValue_ftsRoots]
+      simp only [ftsRecover, evalWithAnswerFn_bind, evalWithAnswerFn_sequenceFin, eval_tweakableHash] at hrecover
+      change truncateHash (f (tweakableHashInput key.parameter (.ftsRoots index) (ftsRootsPayload roots))) = _
+      simpa only [roots, evalWithAnswerFn_bind] using hrecover
+
+theorem opening_trueSecretQuery (leaves : IndexGroup → FtsLeaf) (secrets : FtsTree → Digest) (paths : FtsTree → Fin ftsTreeHeight → Digest)
+    (trace : Trace) (hopening : Opening f key index leaves secrets paths)
+    (hrun : ContainsRun f trace (ftsRecover key.parameter index leaves secrets paths)) (tree : FtsTree) :
+    TrueSecretQuery f key index tree (leaves (ftsIndexOf tree)) trace := by
+  apply hrun
+  simpa only [(hopening tree).1] using ftsRecover_leaf_query_mem f key.parameter index leaves secrets paths tree
+
+theorem recover_classification (leaves : IndexGroup → FtsLeaf) (secrets : FtsTree → Digest) (paths : FtsTree → Fin ftsTreeHeight → Digest)
+    (trace : Trace)
+    (hrecover : evalWithAnswerFn f (ftsRecover key.parameter index leaves secrets paths) = honestFtsKey f key.parameter index (key.ftsSecret index))
+    (hrun : ContainsRun f trace (ftsRecover key.parameter index leaves secrets paths)) :
+    (Opening f key index leaves secrets paths ∧ ∀ tree, TrueSecretQuery f key index tree (leaves (ftsIndexOf tree)) trace) ∨ Exception f key index trace := by
+  by_cases he : Exception f key index trace
+  · exact Or.inr he
+  · have ho := recover_reference f key index leaves secrets paths trace he hrecover hrun
+    exact Or.inl ⟨ho, opening_trueSecretQuery f key index leaves secrets paths trace ho hrun⟩
+
+end FtsVerifierWitness
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/FutureCoverageBound.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/FutureCoverageBound.lean
new file mode 100644
index 000000000..76eca2ac6
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/FutureCoverageBound.lean
@@ -0,0 +1,35 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FewTimeFresh
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem expected_uniformHashOutput_admissible_weight (weight : FewTimeView → ENNReal) :
+    (∑' output, Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] *
+      (if Admissible (truncateMessageDigest output) then weight (hashOutputFewTimeView output) else 0)) =
+      ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ *
+        ∑' target, Pr[= target | ($ᵗ FewTimeView : ProbComp FewTimeView)] * weight target := by
+  have hexpand (output : HashOutput) :
+      (if Admissible (truncateMessageDigest output) then weight (hashOutputFewTimeView output) else 0) =
+        ∑' target, if Admissible (truncateMessageDigest output) ∧ hashOutputFewTimeView output = target then weight target else 0 := by
+    by_cases h : Admissible (truncateMessageDigest output) <;> simp only [h, true_and, false_and, if_true, if_false, tsum_zero]
+    simp
+  simp_rw [hexpand, ← ENNReal.tsum_mul_left]
+  rw [ENNReal.tsum_comm]
+  apply tsum_congr
+  intro target
+  calc
+    _ = Pr[fun output => Admissible (truncateMessageDigest output) ∧ hashOutputFewTimeView output = target |
+        ($ᵗ HashOutput : ProbComp HashOutput)] * weight target := by
+      rw [probEvent_eq_tsum_ite, ← ENNReal.tsum_mul_right]
+      apply tsum_congr
+      intro output
+      split_ifs <;> simp
+    _ = _ := by
+      simp only [← signAttemptResultOfOutput_ne_none_iff]
+      rw [probEvent_uniformHashOutput_admissible_view (fun view => view = target),
+        probEvent_eq_eq_probOutput, mul_assoc]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/HiddenLabelObservation.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/HiddenLabelObservation.lean
new file mode 100644
index 000000000..1b5402e28
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/HiddenLabelObservation.lean
@@ -0,0 +1,106 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Base.UniformTableCompletion
+import SphincsSecurity.Statement
+
+namespace SphincsSecurity.Concrete.HiddenLabelObservation
+
+open _root_.OracleComp ENNReal UniformTableCompletion
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+inductive Probe (Coordinate : Type) where
+  | pair (child parent : Coordinate) (distinct : child ≠ parent) (candidate : Digest)
+  | output (parent : Coordinate)
+
+variable {Coordinate : Type} [Fintype Coordinate] [DecidableEq Coordinate]
+
+def Probe.keep (probe : Probe Coordinate) (labels : Coordinate → Digest) (answer : HashOutput) : Prop :=
+  match probe with
+  | .pair child parent _ candidate => labels child ≠ candidate ∧ labels parent ≠ truncateHash answer
+  | .output parent => labels parent ≠ truncateHash answer
+
+def Probe.restrict (probe : Probe Coordinate) (allowed : Coordinate → Finset Digest)
+    (answer : HashOutput) : Coordinate → Finset Digest :=
+  match probe with
+  | .pair child parent _ candidate => pairedMissAllowed allowed child candidate parent (truncateHash answer)
+  | .output parent => eraseTableValue allowed parent (truncateHash answer)
+
+omit [Fintype Coordinate] in
+theorem Probe.card_lower (probe : Probe Coordinate) (allowed : Coordinate → Finset Digest)
+    (answer : HashOutput) (coordinate : Coordinate) :
+    (allowed coordinate).card - 1 ≤ (probe.restrict allowed answer coordinate).card := by
+  cases probe with
+  | pair child parent distinct candidate =>
+      exact pairedMissAllowed_card_lower allowed child parent distinct candidate (truncateHash answer) coordinate
+  | output parent =>
+      by_cases heq : coordinate = parent
+      · subst coordinate
+        simpa only [Probe.restrict, eraseTableValue, Function.update_self] using
+          (Finset.pred_card_le_card_erase (s := allowed parent) (a := truncateHash answer))
+      · simpa only [Probe.restrict, eraseTableValue, Function.update_of_ne heq] using Nat.sub_le (allowed coordinate).card 1
+
+theorem Probe.mass (probe : Probe Coordinate) (allowed : Coordinate → Finset Digest)
+    (answer : HashOutput) (labels : Coordinate → Digest) :
+    (if probe.keep labels answer then complete allowed labels else 0) =
+      restrictionWeight allowed (probe.restrict allowed answer) * complete (probe.restrict allowed answer) labels := by
+  cases probe with
+  | pair child parent distinct candidate =>
+      have h := paired_mass allowed child parent distinct candidate (truncateHash answer) labels
+      by_cases hk : labels child ≠ candidate ∧ labels parent ≠ truncateHash answer
+      · simpa only [Probe.keep, Probe.restrict, if_pos hk] using h
+      · simpa only [Probe.keep, Probe.restrict, if_neg hk] using h
+  | output parent =>
+      have h := single_mass allowed parent (truncateHash answer) labels
+      by_cases hk : labels parent ≠ truncateHash answer
+      · simpa only [Probe.keep, Probe.restrict, if_pos hk] using h
+      · simpa only [Probe.keep, Probe.restrict, if_neg hk] using h
+
+noncomputable def response (labels : Coordinate → Digest) (probe : Probe Coordinate) : SPMF HashOutput := do
+  let answer ← (liftM (PMF.uniformOfFintype HashOutput) : SPMF HashOutput)
+  if probe.keep labels answer then pure answer else failure
+
+omit [Fintype Coordinate] [DecidableEq Coordinate] in
+theorem response_apply (labels : Coordinate → Digest) (probe : Probe Coordinate) (answer : HashOutput) :
+    response labels probe answer = if probe.keep labels answer then PMF.uniformOfFintype HashOutput answer else 0 := by
+  rw [response, SPMF.bind_apply_eq_tsum]
+  rw [tsum_eq_single answer]
+  · by_cases h : probe.keep labels answer <;> simp only [h, if_true, if_false, SPMF.liftM_apply,
+      SPMF.pure_apply_self, SPMF.failure_apply, mul_one, mul_zero]
+  · intro other hother
+    by_cases h : probe.keep labels other <;> simp only [h, if_true, if_false, SPMF.pure_apply,
+      if_neg (Ne.symm hother), SPMF.failure_apply, mul_zero]
+
+noncomputable def lazyResponse (allowed : Coordinate → Finset Digest) (probe : Probe Coordinate) : SPMF HashOutput :=
+  complete allowed >>= fun labels => response labels probe
+
+theorem lazyResponse_apply (allowed : Coordinate → Finset Digest) (probe : Probe Coordinate) (answer : HashOutput) :
+    lazyResponse allowed probe answer = PMF.uniformOfFintype HashOutput answer *
+      restrictionWeight allowed (probe.restrict allowed answer) := by
+  rw [lazyResponse, SPMF.bind_apply_eq_tsum]
+  simp only [response_apply, mul_ite, mul_zero]
+  calc
+    _ = PMF.uniformOfFintype HashOutput answer *
+        ∑' labels, restrictionWeight allowed (probe.restrict allowed answer) *
+          complete (probe.restrict allowed answer) labels := by
+      rw [← ENNReal.tsum_mul_left]
+      apply tsum_congr
+      intro labels
+      rw [← Probe.mass]
+      split <;> simp only [mul_comm, zero_mul]
+    _ = _ := by rw [ENNReal.tsum_mul_left, weight_tsum_complete]
+
+theorem posterior_mass (allowed : Coordinate → Finset Digest) (probe : Probe Coordinate)
+    (answer : HashOutput) (labels : Coordinate → Digest) :
+    lazyResponse allowed probe answer * complete (probe.restrict allowed answer) labels =
+      complete allowed labels * response labels probe answer := by
+  rw [lazyResponse_apply, mul_assoc, ← Probe.mass, response_apply]
+  split <;> simp only [mul_comm, zero_mul]
+
+theorem lazyResponse_nonempty (allowed : Coordinate → Finset Digest) (probe : Probe Coordinate)
+    (answer : HashOutput) (h : lazyResponse allowed probe answer ≠ 0) :
+    ∀ coordinate, (probe.restrict allowed answer coordinate).Nonempty := by
+  by_contra hnonempty
+  rw [lazyResponse_apply, weight_of_empty _ _ hnonempty, mul_zero] at h
+  exact h rfl
+
+end SphincsSecurity.Concrete.HiddenLabelObservation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/HiddenLabelProbe.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/HiddenLabelProbe.lean
new file mode 100644
index 000000000..2bde33b67
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/HiddenLabelProbe.lean
@@ -0,0 +1,98 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Ots.EncodingProbability
+import SphincsSecurity.Proof.Base.UniformTableRestriction
+namespace SphincsSecurity.Concrete.HiddenLabelProbe
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+variable {Coordinate : Type} [Fintype Coordinate] [DecidableEq Coordinate]
+
+noncomputable def law (allowed : Coordinate → Finset Digest)
+    (ha : ∀ coordinate, (allowed coordinate).Nonempty) : PMF ((Coordinate → Digest) × HashOutput) :=
+  (uniformTable allowed ha).bind fun labels =>
+    (PMF.uniformOfFintype HashOutput).map fun answer => (labels, answer)
+
+def Match (child parent : Coordinate) (candidate : Digest)
+    (result : (Coordinate → Digest) × HashOutput) : Prop :=
+  result.1 child = candidate ∨ truncateHash result.2 = result.1 parent
+
+theorem prob_truncate_eq (target : Digest) :
+    Pr[fun answer => truncateHash answer = target | PMF.uniformOfFintype HashOutput] =
+      (Fintype.card Digest : ENNReal)⁻¹ := by
+  simpa only [probEvent_eq_tsum_ite, probOutput_uniformSample, PMF.probOutput_eq_apply,
+    PMF.uniformOfFintype_apply] using probEvent_uniform_truncateHash_eq target
+
+theorem prob_truncate_ne (target : Digest) :
+    Pr[fun answer => truncateHash answer ≠ target | PMF.uniformOfFintype HashOutput] =
+      1 - (Fintype.card Digest : ENNReal)⁻¹ := by
+  have h := probEvent_compl (PMF.uniformOfFintype HashOutput) (fun answer => truncateHash answer = target)
+  rw [prob_truncate_eq, probFailure_of_liftM_PMF, tsub_zero] at h
+  exact ENNReal.eq_sub_of_add_eq' (by finiteness) (by rwa [add_comm])
+
+theorem prob_survive (allowed : Coordinate → Finset Digest)
+    (ha : ∀ coordinate, (allowed coordinate).Nonempty) (child parent : Coordinate) (candidate : Digest) :
+    Pr[fun result => ¬Match child parent candidate result | law allowed ha] =
+      Pr[fun labels => labels child ≠ candidate | uniformTable allowed ha] *
+        (1 - (Fintype.card Digest : ENNReal)⁻¹) := by
+  change Pr[fun result => ¬Match child parent candidate result |
+    (uniformTable allowed ha) >>= fun labels =>
+      (fun answer => (labels, answer)) <$> PMF.uniformOfFintype HashOutput] = _
+  rw [probEvent_bind_eq_tsum]
+  have hinner (labels : Coordinate → Digest) :
+      Pr[(fun result => ¬Match child parent candidate result) ∘ (fun answer => (labels, answer)) |
+        PMF.uniformOfFintype HashOutput] =
+      if labels child ≠ candidate then 1 - (Fintype.card Digest : ENNReal)⁻¹ else 0 := by
+    by_cases hc : labels child = candidate
+    · simp [Function.comp_def, Match, hc]
+    · simpa only [Function.comp_def, Match, hc, false_or, if_pos hc] using prob_truncate_ne (labels parent)
+  simp only [probEvent_map, hinner, PMF.probOutput_eq_apply, mul_ite, mul_zero]
+  rw [probEvent_eq_tsum_ite, ← ENNReal.tsum_mul_right]
+  simp only [PMF.probOutput_eq_apply, ite_mul, zero_mul]
+
+theorem prob_child_miss (allowed : Coordinate → Finset Digest)
+    (ha : ∀ coordinate, (allowed coordinate).Nonempty) (child : Coordinate) (candidate : Digest) :
+    Pr[fun labels => labels child ≠ candidate | uniformTable allowed ha] =
+      1 - Pr[fun labels => labels child = candidate | uniformTable allowed ha] := by
+  have h := probEvent_compl (uniformTable allowed ha) (fun labels => labels child = candidate)
+  rw [probFailure_of_liftM_PMF, tsub_zero] at h
+  exact ENNReal.eq_sub_of_add_eq' (by simp) (by rwa [add_comm])
+
+theorem prob_child_hit_le (allowed : Coordinate → Finset Digest)
+    (ha : ∀ coordinate, (allowed coordinate).Nonempty) (child : Coordinate) (candidate : Digest)
+    (minimum : Nat) (hmin : minimum ≤ (allowed child).card) :
+    Pr[fun labels => labels child = candidate | uniformTable allowed ha] ≤ (minimum : ENNReal)⁻¹ := by
+  rw [probEvent_uniformTable_eq]
+  split
+  · exact ENNReal.inv_le_inv.mpr (by exact_mod_cast hmin)
+  · exact bot_le
+
+theorem prob_survive_ge (allowed : Coordinate → Finset Digest)
+    (ha : ∀ coordinate, (allowed coordinate).Nonempty) (child parent : Coordinate) (candidate : Digest)
+    (minimum : Nat) (hmin : minimum ≤ (allowed child).card) :
+    (1 - (minimum : ENNReal)⁻¹) ^ 2 ≤
+      Pr[fun result => ¬Match child parent candidate result | law allowed ha] := by
+  have hspace : minimum ≤ Fintype.card Digest := hmin.trans (Finset.card_le_univ _)
+  rw [prob_survive, prob_child_miss, pow_two]
+  exact mul_le_mul' (tsub_le_tsub_left (prob_child_hit_le allowed ha child candidate minimum hmin) _)
+    (tsub_le_tsub_left (ENNReal.inv_le_inv.mpr (by exact_mod_cast hspace)) _)
+
+theorem prob_match_le (allowed : Coordinate → Finset Digest)
+    (ha : ∀ coordinate, (allowed coordinate).Nonempty) (child parent : Coordinate) (candidate : Digest)
+    (minimum : Nat) (hmin : minimum ≤ (allowed child).card) :
+    Pr[Match child parent candidate | law allowed ha] ≤ 1 - (1 - (minimum : ENNReal)⁻¹) ^ 2 := by
+  have h := probEvent_compl (law allowed ha) (Match child parent candidate)
+  rw [probFailure_of_liftM_PMF, tsub_zero] at h
+  have heq := ENNReal.eq_sub_of_add_eq' (by simp) h
+  rw [heq]
+  exact tsub_le_tsub_left (prob_survive_ge allowed ha child parent candidate minimum hmin) _
+
+theorem prob_match_le_rounds (allowed : Coordinate → Finset Digest)
+    (ha : ∀ coordinate, (allowed coordinate).Nonempty) (child parent : Coordinate) (candidate : Digest)
+    (rounds : Nat) (hmin : 2 ^ digestBits - rounds ≤ (allowed child).card) :
+    Pr[Match child parent candidate | law allowed ha] ≤
+      1 - (1 - ((2 ^ digestBits - rounds : Nat) : ENNReal)⁻¹) ^ 2 :=
+  prob_match_le allowed ha child parent candidate _ hmin
+
+end SphincsSecurity.Concrete.HiddenLabelProbe
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/InterleavedCoverStep.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/InterleavedCoverStep.lean
new file mode 100644
index 000000000..9ef933c35
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/InterleavedCoverStep.lean
@@ -0,0 +1,50 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CachedSigningViews
+import SphincsSecurity.Proof.Fts.FewTimeConditionalCoverage
+import SphincsSecurity.Proof.Fts.JointProbeMessageReserve
+import SphincsSecurity.Proof.Fts.FewTimePrehit
+import SphincsSecurity.Proof.Fts.FewTimeWeightedOriginRace
+import SphincsSecurity.Proof.Base.RomQueryCharge
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+abbrev CoverLogState := QueryCache HashSpec × QueryLog SigningSpec
+
+theorem logTracedMappedAdversaryImpl_run_map (key : SecretKey)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CoverLogState) :
+    (logTracedMappedAdversaryImpl key input).run state =
+      (fun result => (result.1, (result.2, state.2 ++ signingLogFragment input result.1))) <$>
+        (unloggedMappedAdversaryImpl key input).run state.1 := by
+  rw [logTracedMappedAdversaryImpl, QueryImpl.extendState_apply]
+  simp only [signingLogUpdate, bind_pure_comp]
+
+theorem logTracedMappedAdversaryImpl_cache_le (key : SecretKey)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CoverLogState)
+    (result : (OracleWorld + SigningSpec).Range input × CoverLogState)
+    (hresult : result ∈ support ((logTracedMappedAdversaryImpl key input).run state)) : state.1 ≤ result.2.1 := by
+  rw [logTracedMappedAdversaryImpl_run_map, support_map] at hresult
+  obtain ⟨base, hbase, rfl⟩ := hresult
+  exact unloggedMappedAdversaryImpl_cache_le key input state.1 base hbase
+
+theorem logTracedMappedAdversaryImpl_signingDigestsCached (key : SecretKey)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CoverLogState)
+    (hsigned : SigningDigestsCached key.parameter state.1 key.root state.2)
+    (result : (OracleWorld + SigningSpec).Range input × CoverLogState)
+    (hresult : result ∈ support ((logTracedMappedAdversaryImpl key input).run state)) :
+    SigningDigestsCached key.parameter result.2.1 key.root result.2.2 := by
+  rw [logTracedMappedAdversaryImpl_run_map, support_map] at hresult
+  obtain ⟨base, hbase, rfl⟩ := hresult
+  cases input with
+  | inl world =>
+      simpa only [signingLogFragment, List.append_nil] using hsigned.mono
+        (unloggedMappedAdversaryImpl_cache_le key (.inl world) state.1 base hbase)
+  | inr message =>
+      change base ∈ support ((simulateQ romImpl (sign key message)).run state.1) at hbase
+      rw [← simulateQ_signWithView_fst_run, support_map] at hbase
+      obtain ⟨viewed, hviewed, rfl⟩ := hbase
+      exact SigningDigestsCached.after_signing key message state.1 viewed.2 state.2 hsigned viewed.1.1 viewed.1.2 hviewed
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/InterleavedResidualDisclosure.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/InterleavedResidualDisclosure.lean
new file mode 100644
index 000000000..8fe33f3bb
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/InterleavedResidualDisclosure.lean
@@ -0,0 +1,82 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.CanonicalProbeCache
+import SphincsSecurity.Proof.Fts.PublicSigningRecord
+namespace SphincsSecurity.Concrete.InterleavedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+structure Routing where
+  disclosed : Index → FtsTree → FtsLeaf → Prop
+  known : Labels
+
+abbrev SigningRecord := (Option Signature × Option FewTimeView) × SigningBoundaryTrace
+
+noncomputable def Routing.disclose (routing : Routing) (view : FewTimeView) (secrets : FtsTree → Digest) : Routing where
+  disclosed index tree leaf := routing.disclosed index tree leaf ∨ index = view.1 ∧ leaf = view.2 tree
+  known coordinate := match coordinate with
+    | .ftsStart index tree leaf => if index = view.1 ∧ leaf = view.2 tree then secrets tree else routing.known coordinate
+    | _ => routing.known coordinate
+
+noncomputable def Routing.afterSigning (routing : Routing) (record : SigningRecord) : Routing :=
+  match record.1.1, record.1.2 with
+  | some signature, some view => routing.disclose view signature.ftsSecret
+  | _, _ => routing
+
+theorem Routing.afterSigning_mono (routing : Routing) (record : SigningRecord)
+    (index : Index) (tree : FtsTree) (leaf : FtsLeaf) :
+    routing.disclosed index tree leaf → (routing.afterSigning record).disclosed index tree leaf := by
+  rcases record with ⟨⟨signature, view⟩, trace⟩
+  cases signature <;> cases view <;> first | exact id | exact Or.inl
+
+theorem hidden_graph_disclosed (words : OtsReferenceWords)
+    (before after : Index → FtsTree → FtsLeaf → Prop) (position : Position) :
+    CanonicalCoordinate.Hidden words before (.graph position) = CanonicalCoordinate.Hidden words after (.graph position) := by
+  cases position <;> rfl
+
+theorem Routing.disclose_agreement (routing : Routing) (words : OtsReferenceWords) (actual : Labels)
+    (hagrees : PublicAgreement words routing.disclosed routing.known actual)
+    (view : FewTimeView) (secrets : FtsTree → Digest)
+    (hsecrets : ∀ tree, secrets tree = actual (.ftsStart view.1 tree (view.2 tree))) :
+    PublicAgreement words (routing.disclose view secrets).disclosed (routing.disclose view secrets).known actual := by
+  intro coordinate hpublic
+  cases coordinate with
+  | otsStart lay tree leaf chain => exact hagrees _ hpublic
+  | graph position =>
+      apply hagrees
+      rw [hidden_graph_disclosed words routing.disclosed (routing.disclose view secrets).disclosed position]
+      exact hpublic
+  | ftsStart index tree leaf =>
+      change ¬¬(routing.disclosed index tree leaf ∨ index = view.1 ∧ leaf = view.2 tree) at hpublic
+      change (if index = view.1 ∧ leaf = view.2 tree then secrets tree else routing.known (.ftsStart index tree leaf)) = _
+      split
+      · rename_i h
+        rcases h with ⟨rfl, rfl⟩
+        exact hsecrets tree
+      · rename_i h
+        exact hagrees _ (not_not.mpr ((not_not.mp hpublic).resolve_right h))
+
+theorem Routing.afterSigning_graph (routing : Routing) (record : SigningRecord) (position : Position) :
+    (routing.afterSigning record).known (.graph position) = routing.known (.graph position) := by
+  rcases record with ⟨⟨signature, view⟩, trace⟩
+  cases signature <;> cases view <;> rfl
+
+theorem Routing.afterSigning_cacheClean (routing : Routing) (record : SigningRecord)
+    (parameter : PublicParameter) (words : OtsReferenceWords) (actual : Labels) (cache : ExternalCache)
+    (hclean : CacheClean parameter words routing.disclosed actual cache) :
+    CacheClean parameter words (routing.afterSigning record).disclosed actual cache :=
+  cacheClean_disclose parameter words routing.disclosed (routing.afterSigning record).disclosed
+    (routing.afterSigning_mono record) actual cache hclean
+
+theorem Routing.afterSigning_completed_agreement (routing : Routing) (words : OtsReferenceWords) (actual : Labels)
+    (hagrees : PublicAgreement words routing.disclosed routing.known actual) (record : PublicSigningRecord) :
+    let completed := completePublicSigningRecord (fun index tree leaf => actual (.ftsStart index tree leaf)) record
+    PublicAgreement words (routing.afterSigning completed).disclosed (routing.afterSigning completed).known actual := by
+  rcases record with ⟨⟨plan, view⟩, trace⟩
+  cases plan <;> cases view <;> simp only [completePublicSigningRecord, Option.map_none, Option.map_some, Routing.afterSigning]
+  all_goals first
+    | exact hagrees
+    | exact routing.disclose_agreement words actual hagrees _ _ (fun _ => rfl)
+
+end SphincsSecurity.Concrete.InterleavedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/JointProbeMessageAnswers.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/JointProbeMessageAnswers.lean
new file mode 100644
index 000000000..784c2c9e6
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/JointProbeMessageAnswers.lean
@@ -0,0 +1,11 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Statement
+
+namespace SphincsSecurity.Concrete.FtsProbeSimulation
+
+open _root_.OracleComp OracleSpec ENNReal
+
+noncomputable def messageAnswers (parameter : PublicParameter) (cache : QueryCache HashSpec) : HashInput → Option HashOutput :=
+  fun payload => cache (tweakableHashInput parameter .message payload)
+
+end SphincsSecurity.Concrete.FtsProbeSimulation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/JointProbeMessageReserve.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/JointProbeMessageReserve.lean
new file mode 100644
index 000000000..1039a2483
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/JointProbeMessageReserve.lean
@@ -0,0 +1,13 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Statement
+
+namespace SphincsSecurity.Concrete.FtsProbeSimulation
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+def MessageHashInput (parameter : PublicParameter) (input : HashInput) : Prop :=
+  ∃ payload, tweakableHashInput parameter .message payload = input
+
+end SphincsSecurity.Concrete.FtsProbeSimulation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/MessageAdmissibleDeficit.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/MessageAdmissibleDeficit.lean
new file mode 100644
index 000000000..8306a6ff7
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/MessageAdmissibleDeficit.lean
@@ -0,0 +1,79 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.MessageNormalizedReuse
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+
+noncomputable def messageAdmissibleDeficit (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) : ENNReal :=
+  cachedMessageEntryCount cache key.parameter key.root message * ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ -
+    cachedMessageEntryCountWhere cache key.parameter key.root message (fun _ => True)
+
+theorem messageDigestFreshRate_balance (key : SecretKey) (message : Message) (cache : QueryCache HashSpec)
+    (q : Nat) (hq : q ≤ 2 ^ 127) (hcache : QueryCache.enncard cache ≤ q) :
+    messageDigestFreshRate key message cache * ((2 ^ randomnessBits : Nat) : ENNReal) +
+      (cachedMessageEntryCount cache key.parameter key.root message + (digestAttemptLimit : ENNReal)) *
+        ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ = ((2 ^ 118 : Nat) : ENNReal) := by
+  let count := cachedMessageEntryCount cache key.parameter key.root message + (digestAttemptLimit : ENNReal)
+  let space : ENNReal := (2 ^ randomnessBits : Nat)
+  let admissible : ENNReal := ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹
+  have hcount : count ≤ space := by
+    apply (add_le_add ((cachedMessageEntryCount_le_enncard cache key.parameter key.root message).trans hcache) le_rfl).trans
+    change (q : ENNReal) + (digestAttemptLimit : ENNReal) ≤ ((2 ^ randomnessBits : Nat) : ENNReal)
+    rw [← Nat.cast_add]
+    exact_mod_cast (show q + digestAttemptLimit ≤ 2 ^ randomnessBits by norm_num [digestAttemptLimit, randomnessBits] at *; omega)
+  have hzero : space ≠ 0 := by dsimp only [space]; positivity
+  have htop : space ≠ ⊤ := by dsimp only [space]; finiteness
+  have hfraction : count * space⁻¹ ≤ 1 :=
+    (mul_le_mul' hcount le_rfl).trans_eq (ENNReal.mul_inv_cancel hzero htop)
+  have hcancel : (count * space⁻¹) * (space * admissible) = count * admissible := by
+    rw [mul_assoc, ← mul_assoc space⁻¹, ENNReal.inv_mul_cancel hzero htop, one_mul]
+  change ((1 - count * space⁻¹) * admissible) * space + count * admissible = _
+  calc
+    _ = ((1 - count * space⁻¹) + count * space⁻¹) * (space * admissible) := by rw [← hcancel]; ring
+    _ = space * admissible := by rw [tsub_add_cancel_of_le hfraction, one_mul]
+    _ = _ := by
+      apply (ENNReal.toReal_eq_toReal_iff' (by dsimp only [space, admissible]; finiteness) (by finiteness)).mp
+      norm_num [space, admissible, ENNReal.toReal_mul, ENNReal.toReal_inv, randomnessBits, ftsTreeHeight]
+
+theorem normalizedMessageReuseWeight_le_deficit (key : SecretKey) (message : Message) (cache : QueryCache HashSpec)
+    (q : Nat) (hq : q ≤ 2 ^ 127) (hcache : QueryCache.enncard cache ≤ q) :
+    normalizedMessageReuseWeight key message cache ≤
+      (((2 ^ 118 : Nat) : ENNReal) - ((digestAttemptLimit : ENNReal) * ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ +
+        messageAdmissibleDeficit key message cache))⁻¹ := by
+  rw [normalizedMessageReuseWeight_eq_inv key message cache q hq hcache]
+  apply ENNReal.inv_le_inv.mpr
+  apply tsub_le_iff_left.mpr
+  rw [← messageDigestFreshRate_balance key message cache q hq hcache, add_mul]
+  have hcount : cachedMessageEntryCount cache key.parameter key.root message * ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ ≤
+      cachedMessageEntryCountWhere cache key.parameter key.root message (fun _ => True) + messageAdmissibleDeficit key message cache :=
+    le_add_tsub
+  have h := add_le_add (add_le_add (le_refl (messageDigestFreshRate key message cache * ((2 ^ randomnessBits : Nat) : ENNReal))) hcount)
+    (le_refl ((digestAttemptLimit : ENNReal) * ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹))
+  convert h using 1 <;> first | rfl | ring
+
+theorem normalizedMessageReuseWeight_le_near_uniform_of_deficit
+    (key : SecretKey) (message : Message) (cache : QueryCache HashSpec)
+    (q : Nat) (hq : q ≤ 2 ^ 127) (hcache : QueryCache.enncard cache ≤ q)
+    (hdeficit : messageAdmissibleDeficit key message cache ≤ ((2 ^ 83 : Nat) : ENNReal)) :
+    normalizedMessageReuseWeight key message cache ≤ (1025 / 1024 : ENNReal) * ((2 ^ 118 : Nat) : ENNReal)⁻¹ := by
+  apply (normalizedMessageReuseWeight_le_deficit key message cache q hq hcache).trans
+  apply (ENNReal.inv_le_inv.mpr (tsub_le_tsub_left (add_le_add le_rfl hdeficit) _)).trans
+  have hsmall : (digestAttemptLimit : ENNReal) * ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ + ((2 ^ 83 : Nat) : ENNReal) <
+      ((2 ^ 118 : Nat) : ENNReal) := by
+    apply (ENNReal.toReal_lt_toReal (by finiteness) (by finiteness)).mp
+    rw [ENNReal.toReal_add (by finiteness) (by finiteness)]
+    norm_num [ENNReal.toReal_mul, ENNReal.toReal_inv, digestAttemptLimit, ftsTreeHeight]
+  apply (ENNReal.toReal_le_toReal (ENNReal.inv_ne_top.mpr (ne_of_gt (tsub_pos_iff_lt.mpr hsmall))) (by finiteness)).mp
+  rw [ENNReal.toReal_inv, ENNReal.toReal_sub_of_le hsmall.le (by finiteness)]
+  rw [ENNReal.toReal_add (by finiteness) (by finiteness)]
+  norm_num [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_div, digestAttemptLimit, ftsTreeHeight]
+
+theorem exactDigestReuseWeight_le_near_uniform_of_deficit
+    (key : SecretKey) (message : Message) (cache : QueryCache HashSpec)
+    (q : Nat) (hq : q ≤ 2 ^ 127) (hcache : QueryCache.enncard cache ≤ q)
+    (hdeficit : messageAdmissibleDeficit key message cache ≤ ((2 ^ 83 : Nat) : ENNReal)) :
+    exactDigestReuseWeight key message cache ≤ (1025 / 1024 : ENNReal) * ((2 ^ 118 : Nat) : ENNReal)⁻¹ :=
+  (exactDigestReuseWeight_le_normalizedMessage key message cache q hq hcache).trans
+    (normalizedMessageReuseWeight_le_near_uniform_of_deficit key message cache q hq hcache hdeficit)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/MessageByteTrace.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/MessageByteTrace.lean
new file mode 100644
index 000000000..63f139b0c
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/MessageByteTrace.lean
@@ -0,0 +1,110 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Ots.PrefixByteRun
+import SphincsSecurity.Proof.Reference.ReferenceJointPrior
+import SphincsSecurity.Proof.Reference.ReferenceAuxiliarySigning
+namespace SphincsSecurity.Concrete.ResidualByteFrontend
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs
+set_option backward.isDefEq.respectTransparency false
+
+def MessageOnly {Result : Type} (parameter : PublicParameter) (computation : OracleComp OracleWorld Result) : Prop :=
+  ∀ input ∈ hashInputs computation, FtsProbeSimulation.MessageHashInput parameter input
+
+theorem messageOnly_pure {Result : Type} (parameter : PublicParameter) (value : Result) :
+    MessageOnly parameter (pure value) := by
+  intro input hinput
+  simp only [hashInputs_pure, Finset.notMem_empty] at hinput
+
+theorem messageOnly_query_bind {Result : Type} (parameter : PublicParameter) (input : OracleWorld.Domain)
+    (next : OracleWorld.Range input → OracleComp OracleWorld Result)
+    (hhead : match input with | .inl _ => True | .inr input => FtsProbeSimulation.MessageHashInput parameter input)
+    (htail : ∀ answer, MessageOnly parameter (next answer)) :
+    MessageOnly parameter (liftM (OracleWorld.query input) >>= next) := by
+  intro row hrow
+  rw [hashInputs_query_bind, Finset.mem_union] at hrow
+  rcases hrow with hheadRow | htailRow
+  · cases input with
+    | inl _ => simp only [Finset.notMem_empty] at hheadRow
+    | inr input =>
+        obtain rfl := Finset.mem_singleton.mp hheadRow
+        exact hhead
+  · obtain ⟨answer, _, hrow⟩ := Finset.mem_biUnion.mp htailRow
+    exact htail answer row hrow
+
+theorem messageOnly_bind {A B : Type} (parameter : PublicParameter) (first : OracleComp OracleWorld A)
+    (next : A → OracleComp OracleWorld B) (hfirst : MessageOnly parameter first)
+    (hnext : ∀ answer, MessageOnly parameter (next answer)) : MessageOnly parameter (first >>= next) := by
+  induction first using OracleComp.inductionOn with
+  | pure value => simpa only [pure_bind] using hnext value
+  | query_bind input tail ih =>
+      rw [bind_assoc]
+      apply messageOnly_query_bind parameter input _
+      · cases input with
+        | inl _ => trivial
+        | inr input => exact hfirst input (mem_hashInputs_hash_bind input tail)
+      · intro answer
+        exact ih answer (fun row hrow => hfirst row ((hashInputs_next_subset input tail answer) hrow))
+
+theorem messageOnly_lift_prob {Result : Type} (parameter : PublicParameter) (computation : ProbComp Result) :
+    MessageOnly parameter (liftM computation) := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => rw [liftM_pure]; exact messageOnly_pure parameter value
+  | query_bind input next ih =>
+      rw [liftM_bind]
+      exact messageOnly_query_bind parameter (.inl input) _ trivial ih
+
+noncomputable def applyBoundary (memory : ExternalMemory) (trace : SigningBoundaryTrace) : ExternalMemory :=
+  ⟨trace.messageCalls.foldl (fun cache entry => Function.update cache entry.1 (some entry.2)) memory.cache,
+    memory.hashCalls + trace.hashCalls, memory.probes⟩
+
+theorem applyBoundary_one (memory : ExternalMemory) : applyBoundary memory 1 = memory := by
+  cases memory
+  rfl
+
+theorem applyBoundary_mul (memory : ExternalMemory) (left right : SigningBoundaryTrace) :
+    applyBoundary memory (left * right) = applyBoundary (applyBoundary memory left) right := by
+  simp only [applyBoundary, SigningBoundaryTrace.messageCalls_mul, SigningBoundaryTrace.hashCalls_mul,
+    List.foldl_append, Nat.add_assoc]
+
+noncomputable def messageStep (oracle : QueryImpl HashSpec Id) (input : HashInput) (memory : ExternalMemory) :
+    Option HashOutput × ExternalMemory :=
+  (some (oracle input), storeReply { memory with hashCalls := memory.hashCalls + 1 } input (oracle input))
+
+theorem fixedBoundaryRun_query_bind {Result : Type} (parameter : PublicParameter) (oracle : QueryImpl HashSpec Id)
+    (input : OracleWorld.Domain) (next : OracleWorld.Range input → OracleComp OracleWorld Result) :
+    fixedBoundaryRun parameter oracle (liftM (OracleWorld.query input) >>= next) =
+      fixedHashWorld oracle input >>= fun answer =>
+        (fun result => (result.1, signingBoundaryTrace parameter input answer * result.2)) <$>
+          fixedBoundaryRun parameter oracle (next answer) := by
+  simp [fixedBoundaryRun, QueryImpl.withTrace_apply]
+
+theorem message_not_encoding (parameter : PublicParameter) (input : HashInput)
+    (hmessage : FtsProbeSimulation.MessageHashInput parameter input) (position : EncodingPosition) :
+    ¬AtEncodingPosition parameter input position := by
+  obtain ⟨payload, rfl⟩ := hmessage
+  rintro ⟨other, heq⟩
+  have hdomain := (tweakableHashInput_injective parameter (by trivial) (by trivial) heq).1
+  simp only [EncodingPosition.domain, reduceCtorEq] at hdomain
+
+theorem checkedFixedStep_message (parameter : PublicParameter) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known actual : Labels) (messages : EncodingPosition → Digest)
+    (selections : ReferenceFamily) (oracle : QueryImpl HashSpec Id) (input : HashInput)
+    (hmessage : FtsProbeSimulation.MessageHashInput parameter input) (memory : ExternalMemory) :
+    checkedResult (PublicEncodingMatch.Match parameter messages words selections) input
+      (fixedStep parameter words disclosed known actual oracle input memory) = messageStep oracle input memory := by
+  have hdecode : decodePosition parameter input = none := by
+    obtain ⟨payload, rfl⟩ := hmessage
+    exact decodePosition_message parameter payload
+  have hbad : ¬CanonicalProbeRouting.Bad parameter words disclosed actual input (oracle input) := by
+    rintro ⟨position, hat, _⟩
+    exact (decodePosition_none_iff parameter input).mp hdecode position hat
+  have hmatch : ¬PublicEncodingMatch.Match parameter messages words selections input (oracle input) := by
+    rintro ⟨position, hat, _⟩
+    exact message_not_encoding parameter input hmessage position hat
+  simp only [checkedResult, fixedStep, fixedAnswer, if_neg hbad, Option.bind_some, if_neg hmatch,
+    Option.elim_some, messageStep, charge, route, hdecode, Option.elim_none]
+  cases memory.cache input <;> simp only [Nat.add_zero]
+
+end SphincsSecurity.Concrete.ResidualByteFrontend
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/MessageCacheCountGrowth.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/MessageCacheCountGrowth.lean
new file mode 100644
index 000000000..c641f0d8a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/MessageCacheCountGrowth.lean
@@ -0,0 +1,51 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FewTimeUniform
+import SphincsSecurity.Proof.Fts.MessagePrehit
+namespace SphincsSecurity
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+
+theorem cachedMessageEntryCount_cacheQuery_le (parameter : PublicParameter) (root : Digest) (message : Message)
+    (cache : QueryCache HashSpec) (input : HashInput) (output : HashOutput) :
+    cachedMessageEntryCount (cache.cacheQuery input output) parameter root message ≤
+      cachedMessageEntryCount cache parameter root message + 1 := by
+  have hsubset : cachedMessageInputSet (cache.cacheQuery input output) parameter root message ⊆
+      insert ⟨input, output⟩ (cachedMessageInputSet cache parameter root message) := by
+    intro entry hentry
+    rcases QueryCache.toSet_cacheQuery_subset_insert cache input output hentry.1 with heq | hold
+    · exact Or.inl heq
+    · exact Or.inr ⟨hold, hentry.2⟩
+  exact (ENat.toENNReal_mono (Set.encard_le_encard hsubset)).trans
+    (by simpa only [cachedMessageEntryCount, ENat.toENNReal_add, ENat.toENNReal_one] using
+      ENat.toENNReal_mono (Set.encard_insert_le (cachedMessageInputSet cache parameter root message) ⟨input, output⟩))
+
+theorem randomOracle_cachedMessageEntryCount_le (parameter : PublicParameter) (root : Digest) (message : Message)
+    (input : HashInput) (cache : QueryCache HashSpec) (result : HashOutput × QueryCache HashSpec)
+    (hr : result ∈ support ((randomOracle input).run cache)) :
+    cachedMessageEntryCount result.2 parameter root message ≤ cachedMessageEntryCount cache parameter root message + 1 := by
+  cases hc : cache input with
+  | none =>
+      rw [randomOracle, QueryImpl.withCaching_run_none _ hc, support_map] at hr
+      obtain ⟨output, _, rfl⟩ := hr
+      exact cachedMessageEntryCount_cacheQuery_le parameter root message cache input output
+  | some output =>
+      rw [randomOracle, QueryImpl.withCaching_run_some _ hc, mem_support_pure_iff] at hr
+      subst result
+      exact le_self_add
+
+namespace Concrete
+
+theorem signAttempt_cachedMessageEntryCount_le (key : SecretKey) (message : Message) (randomness : Randomness)
+    (cache : QueryCache HashSpec) (result : Option (Index × (IndexGroup → FtsLeaf)) × QueryCache HashSpec)
+    (hr : result ∈ support ((simulateQ (randomOracle : QueryImpl HashSpec _) (signAttempt key message randomness)).run cache)) :
+    cachedMessageEntryCount result.2 key.parameter key.root message ≤ cachedMessageEntryCount cache key.parameter key.root message + 1 := by
+  rw [simulateQ_signAttempt_run_eq, mem_support_bind_iff] at hr
+  obtain ⟨oracleResult, horacle, hpure⟩ := hr
+  simp only [mem_support_pure_iff] at hpure
+  subst result
+  exact randomOracle_cachedMessageEntryCount_le key.parameter key.root message
+    (tweakableHashInput key.parameter .message (messageDigestPayload key.root message randomness)) cache oracleResult horacle
+
+end Concrete
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/MessageCacheProjection.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/MessageCacheProjection.lean
new file mode 100644
index 000000000..1e555ae06
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/MessageCacheProjection.lean
@@ -0,0 +1,74 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.SigningProposalRecord
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (MessageHashInput messageAnswers)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] signDigestLoop signAttempt
+
+noncomputable def messageOnlyCache (parameter : PublicParameter) (cache : QueryCache HashSpec) : QueryCache HashSpec :=
+  fun input => if MessageHashInput parameter input then cache input else none
+
+theorem messageOnlyCache_apply (parameter : PublicParameter) (cache : QueryCache HashSpec) (input : HashInput)
+    (hinput : MessageHashInput parameter input) : messageOnlyCache parameter cache input = cache input :=
+  if_pos hinput
+
+theorem messageOnlyCache_payload (parameter : PublicParameter) (cache : QueryCache HashSpec) (payload : HashInput) :
+    messageOnlyCache parameter cache (tweakableHashInput parameter .message payload) =
+      cache (tweakableHashInput parameter .message payload) :=
+  messageOnlyCache_apply parameter cache _ ⟨payload, rfl⟩
+
+theorem messageAnswers_messageOnlyCache (parameter : PublicParameter) (cache : QueryCache HashSpec) :
+    messageAnswers parameter (messageOnlyCache parameter cache) = messageAnswers parameter cache := by
+  funext payload
+  exact messageOnlyCache_payload parameter cache payload
+
+theorem messageOnlyCache_eq_of_messageAnswers_eq (parameter : PublicParameter) (left right : QueryCache HashSpec)
+    (hcache : messageAnswers parameter left = messageAnswers parameter right) :
+    messageOnlyCache parameter left = messageOnlyCache parameter right := by
+  funext input
+  by_cases hmessage : MessageHashInput parameter input
+  · obtain ⟨payload, rfl⟩ := hmessage
+    rw [messageOnlyCache_payload, messageOnlyCache_payload]
+    exact congrFun hcache payload
+  · simp only [messageOnlyCache, if_neg hmessage]
+
+theorem cachedMessageInputSet_messageOnlyCache (parameter : PublicParameter) (root : Digest) (message : Message)
+    (cache : QueryCache HashSpec) :
+    cachedMessageInputSet (messageOnlyCache parameter cache) parameter root message =
+      cachedMessageInputSet cache parameter root message := by
+  ext ⟨input, output⟩
+  constructor <;> rintro ⟨hcached, randomness, hinput⟩
+  · refine ⟨?_, randomness, hinput⟩
+    change input = tweakableHashInput parameter .message (messageDigestPayload root message randomness) at hinput
+    subst input
+    simpa only [QueryCache.mem_toSet, messageOnlyCache_payload] using hcached
+  · refine ⟨?_, randomness, hinput⟩
+    change input = tweakableHashInput parameter .message (messageDigestPayload root message randomness) at hinput
+    subst input
+    simpa only [QueryCache.mem_toSet, messageOnlyCache_payload] using hcached
+
+theorem cachedMessageEntryCount_messageOnlyCache (parameter : PublicParameter) (root : Digest) (message : Message)
+    (cache : QueryCache HashSpec) :
+    cachedMessageEntryCount (messageOnlyCache parameter cache) parameter root message =
+      cachedMessageEntryCount cache parameter root message := by
+  rw [cachedMessageEntryCount, cachedMessageEntryCount, cachedMessageInputSet_messageOnlyCache]
+
+theorem cachedMessageEntryCountWhere_messageOnlyCache (parameter : PublicParameter) (root : Digest) (message : Message)
+    (cache : QueryCache HashSpec) (P : FewTimeView → Prop) :
+    cachedMessageEntryCountWhere (messageOnlyCache parameter cache) parameter root message P =
+      cachedMessageEntryCountWhere cache parameter root message P := by
+  simp only [cachedMessageEntryCountWhere, cachedMessageInputSetWhere, cachedMessageInputSet_messageOnlyCache]
+
+theorem cacheMessageWeight_messageOnlyCache (parameter : PublicParameter) (cache : QueryCache HashSpec)
+    (weight : HashInput → FewTimeView → ENNReal) :
+    cacheMessageWeight parameter weight (messageOnlyCache parameter cache) = cacheMessageWeight parameter weight cache := by
+  apply tsum_congr
+  intro input
+  by_cases hmessage : MessageHashInput parameter input
+  · simp only [cacheMessageEntryWeight, messageOnlyCache_apply parameter cache input hmessage]
+  · simp only [cacheMessageEntryWeight, messageOnlyCache, if_neg hmessage]
+    cases cache input <;> simp only [hmessage, false_and, if_false]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/MessageCertificateProjection.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/MessageCertificateProjection.lean
new file mode 100644
index 000000000..de0e22181
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/MessageCertificateProjection.lean
@@ -0,0 +1,74 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CertificateBoundaryInvariants
+import SphincsSecurity.Proof.Fts.MessageCacheProjection
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (MessageHashInput messageAnswers)
+attribute [local instance] Classical.propDecidable
+
+theorem observedTargetShapeVector_messageOnlyCache (key : SecretKey) (payload : HashInput) (target : FewTimeView)
+    (cache : QueryCache HashSpec) (log : QueryLog SigningSpec) :
+    observedTargetShapeVector key payload target (messageOnlyCache key.parameter cache, log) =
+      observedTargetShapeVector key payload target (cache, log) := by
+  funext groups remaining
+  simp only [observedTargetShapeVector, targetShapeMoments, normalizedCachedTargetSubsetMatch_eq_weight,
+    cacheMessageWeight_messageOnlyCache, normalizedTargetLogProduct, normalizedTargetLogMatch,
+    messageAnswers_messageOnlyCache]
+
+theorem targetCertificateForecast_messageOnlyCache (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat)
+    (required : Finset FtsTree) (cache : QueryCache HashSpec) (log : QueryLog SigningSpec)
+    (input : HashInput) (target : FewTimeView) :
+    targetCertificateForecast key reuse budget signatures required (messageOnlyCache key.parameter cache, log) input target =
+      targetCertificateForecast key reuse budget signatures required (cache, log) input target := by
+  simp only [targetCertificateForecast, reuseTargetEnvelope, observedTargetShapeVector_messageOnlyCache]
+
+theorem bankedCacheWeight_messageOnlyCache (parameter : PublicParameter)
+    (weight : HashInput → FewTimeView → ENNReal) (bank : HashInput → Bool) (stopped : Bool) (cache : QueryCache HashSpec) :
+    bankedCacheWeight parameter weight bank stopped (messageOnlyCache parameter cache) =
+      bankedCacheWeight parameter weight bank stopped cache := by
+  cases stopped <;> simp only [bankedCacheWeight_stopped, bankedCacheWeight_live, cacheMessageWeight_messageOnlyCache]
+
+theorem bankedTargetEnvelope_messageOnlyCache (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat)
+    (required : Finset FtsTree) (cache : QueryCache HashSpec) (log : QueryLog SigningSpec)
+    (bank : HashInput → Bool) (stopped : Bool) :
+    bankedTargetEnvelope key reuse budget signatures required (messageOnlyCache key.parameter cache, log) bank stopped =
+      bankedTargetEnvelope key reuse budget signatures required (cache, log) bank stopped := by
+  simp only [bankedTargetEnvelope]
+  have hweight := funext fun input => funext fun target =>
+    targetCertificateForecast_messageOnlyCache key reuse budget signatures required cache log input target
+  rw [hweight, bankedCacheWeight_messageOnlyCache]
+
+theorem bankedTargetEnvelope_congr_messageHistory (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat)
+    (required : Finset FtsTree) (before after : QueryCache HashSpec)
+    (hcache : messageAnswers key.parameter before = messageAnswers key.parameter after)
+    (log : QueryLog SigningSpec) (bank : HashInput → Bool) (stopped : Bool) :
+    bankedTargetEnvelope key reuse budget signatures required (before, log) bank stopped =
+      bankedTargetEnvelope key reuse budget signatures required (after, log) bank stopped := by
+  rw [← bankedTargetEnvelope_messageOnlyCache key reuse budget signatures required before log bank stopped,
+    ← bankedTargetEnvelope_messageOnlyCache key reuse budget signatures required after log bank stopped,
+    messageOnlyCache_eq_of_messageAnswers_eq key.parameter before after hcache]
+
+theorem bankedTargetEnvelope_complete_le (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat)
+    (required : Finset FtsTree) (state : CoverLogState) (bank : HashInput → Bool) (stopped : Bool) :
+    bankedTargetEnvelope key reuse budget signatures required state (completedTargetBank key required state bank) stopped ≤
+      bankedTargetEnvelope key reuse budget signatures required state bank false := by
+  apply bankedCacheWeight_bank_le
+  intro input hcomplete
+  exact one_le_targetCertificateEntry_of_certificate key reuse budget signatures required state input
+    (of_decide_eq_true hcomplete)
+
+theorem bankedProposalRecordValue_world_le_of_messageHistory (key : SecretKey) (reuse : ENNReal)
+    (budget signatures : Nat) (required : Finset FtsTree) (state : CoverLogState)
+    (bank : HashInput → Bool) (input : OracleWorld.Domain) (record : ProposalExecutionRecord (.inl input))
+    (stopped : Bool) (hcache : messageAnswers key.parameter record.cache = messageAnswers key.parameter state.1) :
+    bankedProposalRecordValue key reuse budget signatures required state bank (.inl input) record stopped ≤
+      bankedTargetEnvelope key reuse budget signatures required state bank false := by
+  simp only [bankedProposalRecordValue, proposalRecordLogState, signingLogFragment, List.append_nil]
+  apply (bankedTargetEnvelope_complete_le key reuse (budget - record.trace.hashCalls) signatures required
+    (record.cache, state.2) bank stopped).trans
+  rw [bankedTargetEnvelope_congr_messageHistory key reuse (budget - record.trace.hashCalls) signatures required
+    record.cache state.1 hcache state.2 bank false]
+  exact bankedTargetEnvelope_budget_mono key reuse signatures required state bank false (Nat.sub_le _ _)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/MessageDeficitCacheGrowth.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/MessageDeficitCacheGrowth.lean
new file mode 100644
index 000000000..def8c1508
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/MessageDeficitCacheGrowth.lean
@@ -0,0 +1,93 @@
+import SphincsSecurity.Proof.Fts.MessageDeficitMomentGrowth
+namespace SphincsSecurity
+
+open OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+def MessageInputAt (parameter : PublicParameter) (root : Digest) (message : Message) (input : HashInput) : Prop :=
+  ∃ randomness, input = tweakableHashInput parameter .message (Concrete.messageDigestPayload root message randomness)
+
+theorem MessageInputAt.unique {parameter : PublicParameter} {root : Digest} {left right : Message} {input : HashInput}
+    (hl : MessageInputAt parameter root left input) (hr : MessageInputAt parameter root right input) : left = right := by
+  obtain ⟨lr, hl⟩ := hl
+  obtain ⟨rr, hr⟩ := hr
+  exact (Concrete.messageDigestPayload_injective root
+    (tweakableHashInput_injective parameter (by trivial) (by trivial) (hl.symm.trans hr)).2).1
+
+private theorem filteredCache_encard_cacheQuery (cache : QueryCache HashSpec) (input : HashInput) (output : HashOutput)
+    (hfresh : cache input = none) (P : Sigma HashSpec.Range → Prop) :
+    (({entry ∈ (cache.cacheQuery input output).toSet | P entry}.encard : ENat) : ENNReal) =
+      (({entry ∈ cache.toSet | P entry}.encard : ENat) : ENNReal) + if P ⟨input, output⟩ then 1 else 0 := by
+  have hset : (cache.cacheQuery input output).toSet = insert ⟨input, output⟩ cache.toSet := by
+    apply Set.Subset.antisymm (QueryCache.toSet_cacheQuery_subset_insert cache input output)
+    rintro entry (heq | hold)
+    · subst entry
+      exact QueryCache.cacheQuery_self _ _ _
+    · exact QueryCache.toSet_mono (QueryCache.le_cacheQuery cache hfresh) hold
+  by_cases hp : P ⟨input, output⟩
+  · have heq : {entry ∈ (cache.cacheQuery input output).toSet | P entry} =
+        insert ⟨input, output⟩ {entry ∈ cache.toSet | P entry} := by
+      rw [hset]
+      ext entry
+      simp only [Set.mem_setOf_eq, Set.mem_insert_iff]
+      constructor
+      · rintro ⟨heq | hold, hentry⟩
+        · exact Or.inl heq
+        · exact Or.inr ⟨hold, hentry⟩
+      · rintro (rfl | ⟨hold, hentry⟩)
+        · exact ⟨Or.inl rfl, hp⟩
+        · exact ⟨Or.inr hold, hentry⟩
+    have hnot : (⟨input, output⟩ : Sigma HashSpec.Range) ∉ {entry ∈ cache.toSet | P entry} := by
+      rintro ⟨hmem, _⟩
+      change cache input = some output at hmem
+      rw [hfresh] at hmem
+      cases hmem
+    rw [heq, Set.encard_insert_of_notMem hnot, if_pos hp, ENat.toENNReal_add, ENat.toENNReal_one]
+  · have heq : {entry ∈ (cache.cacheQuery input output).toSet | P entry} = {entry ∈ cache.toSet | P entry} := by
+      rw [hset]
+      ext entry
+      simp only [Set.mem_setOf_eq, Set.mem_insert_iff]
+      constructor
+      · rintro ⟨rfl | hold, hentry⟩
+        · exact False.elim (hp hentry)
+        · exact ⟨hold, hentry⟩
+      · rintro ⟨hold, hentry⟩
+        exact ⟨Or.inr hold, hentry⟩
+    rw [heq, if_neg hp, add_zero]
+
+theorem cachedMessageEntryCount_cacheQuery (parameter : PublicParameter) (root : Digest) (message : Message)
+    (cache : QueryCache HashSpec) (input : HashInput) (output : HashOutput) (hfresh : cache input = none) :
+    cachedMessageEntryCount (cache.cacheQuery input output) parameter root message =
+      cachedMessageEntryCount cache parameter root message + if MessageInputAt parameter root message input then 1 else 0 :=
+  filteredCache_encard_cacheQuery cache input output hfresh (fun entry => MessageInputAt parameter root message entry.1)
+
+theorem cachedMessageEntryCountWhere_cacheQuery (parameter : PublicParameter) (root : Digest) (message : Message)
+    (cache : QueryCache HashSpec) (input : HashInput) (output : HashOutput) (hfresh : cache input = none) (P : Concrete.FewTimeView → Prop) :
+    cachedMessageEntryCountWhere (cache.cacheQuery input output) parameter root message P =
+      cachedMessageEntryCountWhere cache parameter root message P +
+        if MessageInputAt parameter root message input ∧ Concrete.signAttemptResultOfOutput output ≠ none ∧
+          P (Concrete.hashOutputFewTimeView output) then 1 else 0 := by
+  have h := filteredCache_encard_cacheQuery cache input output hfresh
+      (fun entry => MessageInputAt parameter root message entry.1 ∧ Concrete.signAttemptResultOfOutput entry.2 ≠ none ∧
+        P (Concrete.hashOutputFewTimeView entry.2))
+  simp only [cachedMessageEntryCountWhere, cachedMessageInputSetWhere, cachedMessageInputSet, MessageInputAt, Set.mem_setOf_eq, and_assoc] at h ⊢
+  split_ifs at h ⊢ <;> exact h
+
+theorem messageDeficitScore_cacheQuery (parameter : PublicParameter) (root : Digest) (message : Message)
+    (cache : QueryCache HashSpec) (hfinite : Finite cache) (input : HashInput) (output : HashOutput) (hfresh : cache input = none) :
+    messageDeficitScore parameter root message (cache.cacheQuery input output) =
+      if MessageInputAt parameter root message input then
+        messageDeficitScore parameter root message cache + (if Concrete.Admissible (truncateMessageDigest output) then -1023 else 1)
+      else messageDeficitScore parameter root message cache := by
+  rw [messageDeficitScore, cachedMessageEntryCount_cacheQuery _ _ _ _ _ _ hfresh,
+    cachedMessageEntryCountWhere_cacheQuery _ _ _ _ _ _ hfresh]
+  simp only [and_true, Concrete.signAttemptResultOfOutput_ne_none_iff]
+  split_ifs <;> try tauto
+  all_goals
+    rw [ENNReal.toReal_add (cachedMessageEntryCount_ne_top_of_finite parameter root message cache hfinite) (by finiteness),
+      ENNReal.toReal_add (cachedMessageEntryCountWhere_ne_top_of_finite parameter root message cache hfinite _) (by finiteness)]
+    simp only [ENNReal.toReal_one, ENNReal.toReal_zero, messageDeficitScore]
+    ring
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/MessageDeficitConcentration.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/MessageDeficitConcentration.lean
new file mode 100644
index 000000000..705e54715
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/MessageDeficitConcentration.lean
@@ -0,0 +1,42 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.MessageDeficitMomentGrowth
+namespace SphincsSecurity
+
+open OracleComp OracleSpec ENNReal
+
+def MessageDeficitExceptional (key : SecretKey) (cache : QueryCache HashSpec) : Prop :=
+  ∃ message, ((2 ^ 83 : Nat) : ENNReal) < Concrete.messageAdmissibleDeficit key message cache
+
+theorem positiveScoreMoment_eq_pow_ofReal (score : ℝ) (power : Nat) :
+    positiveScoreMoment score power = ENNReal.ofReal score ^ power := by
+  rw [positiveScoreMoment, ENNReal.ofReal_pow (le_max_right _ _)]
+  simp only [ENNReal.ofReal_max, ENNReal.ofReal_zero, max_eq_left (show 0 ≤ ENNReal.ofReal score from zero_le)]
+
+theorem messageDeficitExceptional_fourthMoment_le (key : SecretKey)
+    (cache : QueryCache HashSpec) (hfinite : Finite cache) (hbad : MessageDeficitExceptional key cache) :
+    (2 : ENNReal) ^ 372 ≤ messageDeficitMoment key.parameter key.root cache 4 := by
+  obtain ⟨message, hmessage⟩ := hbad
+  have hscaled : (2 : ENNReal) ^ 93 ≤ 1024 * Concrete.messageAdmissibleDeficit key message cache := by
+    calc
+      _ = 1024 * ((2 ^ 83 : Nat) : ENNReal) := by norm_num
+      _ ≤ _ := mul_le_mul' le_rfl hmessage.le
+  calc
+    (2 : ENNReal) ^ 372 = ((2 : ENNReal) ^ 93) ^ 4 := by rw [← pow_mul]
+    _ ≤ (1024 * Concrete.messageAdmissibleDeficit key message cache) ^ 4 := pow_le_pow_left' hscaled 4
+    _ = positiveScoreMoment (messageDeficitScore key.parameter key.root message cache) 4 := by
+      rw [positiveScoreMoment_eq_pow_ofReal, messageDeficitScore_ofReal_eq key message cache hfinite]
+    _ ≤ _ := positiveScoreMoment_le_messageDeficitMoment key.parameter key.root cache 4 message
+
+theorem cachedMessageEntryCount_zero_of_no_inputs (parameter : PublicParameter) (root : Digest)
+    (cache : QueryCache HashSpec) (hnone : ∀ payload, cache (tweakableHashInput parameter .message payload) = none)
+    (message : Message) : cachedMessageEntryCount cache parameter root message = 0 := by
+  have hempty : cachedMessageInputSet cache parameter root message = ∅ := by
+    apply Set.eq_empty_iff_forall_notMem.mpr
+    rintro ⟨input, answer⟩ ⟨hcached, randomness, hinput⟩
+    change cache input = some answer at hcached
+    have h := hnone (Concrete.messageDigestPayload root message randomness)
+    rw [← hinput, hcached] at h
+    cases h
+  simp only [cachedMessageEntryCount, hempty, Set.encard_empty, ENat.toENNReal_zero]
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/MessageDeficitHashMoments.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/MessageDeficitHashMoments.lean
new file mode 100644
index 000000000..c2724681e
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/MessageDeficitHashMoments.lean
@@ -0,0 +1,114 @@
+import SphincsSecurity.Proof.Fts.MessageDeficitCacheGrowth
+import SphincsSecurity.Proof.Fts.CachedIndexHashMoments
+
+/-! ## MessageDeficitBernoulli -/
+
+namespace SphincsSecurity
+
+open OracleComp OracleSpec ENNReal
+
+theorem messageDeficit_secondMoment_le (score : ℝ) :
+    (1 / 1024 : ℝ) * max (score - 1023) 0 ^ 2 +
+      (1023 / 1024 : ℝ) * max (score + 1) 0 ^ 2 ≤ max score 0 ^ 2 + 1023 := by
+  calc
+    _ ≤ (1 / 1024 : ℝ) * (max score 0 - 1023) ^ 2 + (1023 / 1024 : ℝ) * (max score 0 + 1) ^ 2 := by
+      apply add_le_add
+      · exact mul_le_mul_of_nonneg_left (positivePart_shift_even_le score (-1023) 2 (by decide)) (by norm_num)
+      · exact mul_le_mul_of_nonneg_left (positivePart_shift_even_le score 1 2 (by decide)) (by norm_num)
+    _ = _ := by ring
+
+theorem messageDeficit_secondMoment_ennreal (score : ℝ) :
+    (1024 : ENNReal)⁻¹ * positiveScoreMoment (score - 1023) 2 +
+      (1 - (1024 : ENNReal)⁻¹) * positiveScoreMoment (score + 1) 2 ≤ positiveScoreMoment score 2 + 1023 := by
+  have hsub : (1 - (1024 : ENNReal)⁻¹).toReal = (1023 / 1024 : ℝ) := by
+    rw [ENNReal.toReal_sub_of_le (by norm_num) (by finiteness)]
+    norm_num [ENNReal.toReal_inv]
+  apply (ENNReal.toReal_le_toReal (by unfold positiveScoreMoment; finiteness) (by unfold positiveScoreMoment; finiteness)).mp
+  rw [ENNReal.toReal_add (by unfold positiveScoreMoment; finiteness) (by unfold positiveScoreMoment; finiteness),
+    ENNReal.toReal_add (positiveScoreMoment_ne_top _ _) (by finiteness)]
+  simpa only [ENNReal.toReal_mul, hsub, ENNReal.toReal_inv, ENNReal.toReal_ofNat, positiveScoreMoment,
+    ENNReal.toReal_ofReal (pow_nonneg (le_max_right _ _) _), one_div] using messageDeficit_secondMoment_le score
+
+end SphincsSecurity
+
+namespace SphincsSecurity
+
+open OracleComp OracleSpec ENNReal
+open Concrete (Admissible)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] messageDeficitScore positiveScoreMoment messageDeficitMoment
+set_option backward.isDefEq.respectTransparency false
+
+theorem probEvent_uniformHashOutput_admissible :
+    Pr[fun output => Admissible (truncateMessageDigest output) | ($ᵗ HashOutput : ProbComp HashOutput)] = (1024 : ENNReal)⁻¹ := by
+  simpa only [and_true, probEvent_True_eq_sub, probFailure_of_liftM_PMF, tsub_zero, mul_one,
+    Concrete.signAttemptResultOfOutput_ne_none_iff, ftsTreeHeight, Nat.reducePow, Nat.cast_ofNat] using
+    Concrete.probEvent_uniformHashOutput_admissible_view (fun _ => True)
+
+private theorem expected_admissible_choice (accepted rejected : ENNReal) :
+    (∑' output, Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] *
+      (if Admissible (truncateMessageDigest output) then accepted else rejected)) =
+      (1024 : ENNReal)⁻¹ * accepted + (1 - (1024 : ENNReal)⁻¹) * rejected := by
+  have hnot : Pr[fun output => ¬Admissible (truncateMessageDigest output) | ($ᵗ HashOutput : ProbComp HashOutput)] = 1 - (1024 : ENNReal)⁻¹ := by
+    have h := probEvent_compl ($ᵗ HashOutput : ProbComp HashOutput) (fun output => Admissible (truncateMessageDigest output))
+    rw [probFailure_of_liftM_PMF, tsub_zero, probEvent_uniformHashOutput_admissible, add_comm] at h
+    exact ENNReal.eq_sub_of_add_eq' (by finiteness) h
+  have hsplit (output : HashOutput) :
+      Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] * (if Admissible (truncateMessageDigest output) then accepted else rejected) =
+        (if Admissible (truncateMessageDigest output) then Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] else 0) * accepted +
+        (if ¬Admissible (truncateMessageDigest output) then Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] else 0) * rejected := by
+    split_ifs <;> simp_all only [zero_mul, zero_add, add_zero]
+  simp_rw [hsplit, ENNReal.tsum_add, ENNReal.tsum_mul_right, ← probEvent_eq_tsum_ite, probEvent_uniformHashOutput_admissible, hnot]
+
+private theorem expected_messageDeficitMoment_at (parameter : PublicParameter) (root : Digest) (message : Message)
+    (cache : QueryCache HashSpec) (hfinite : Finite cache) (input : HashInput) (hfresh : cache input = none)
+    (hat : MessageInputAt parameter root message input) (power : Nat) (charge : ENNReal)
+    (hshift : (1024 : ENNReal)⁻¹ * positiveScoreMoment (messageDeficitScore parameter root message cache - 1023) power +
+      (1 - (1024 : ENNReal)⁻¹) * positiveScoreMoment (messageDeficitScore parameter root message cache + 1) power ≤
+      positiveScoreMoment (messageDeficitScore parameter root message cache) power + charge) :
+    (∑' output, Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] *
+      messageDeficitMoment parameter root (cache.cacheQuery input output) power) ≤ messageDeficitMoment parameter root cache power + charge := by
+  let rest := ∑ other ∈ Finset.univ.erase message, positiveScoreMoment (messageDeficitScore parameter root other cache) power
+  have hbefore : messageDeficitMoment parameter root cache power = positiveScoreMoment (messageDeficitScore parameter root message cache) power + rest := by
+    unfold messageDeficitMoment
+    exact (Finset.add_sum_erase _ _ (Finset.mem_univ message)).symm
+  have hafter (output : HashOutput) : messageDeficitMoment parameter root (cache.cacheQuery input output) power =
+      (if Admissible (truncateMessageDigest output) then positiveScoreMoment (messageDeficitScore parameter root message cache - 1023) power
+       else positiveScoreMoment (messageDeficitScore parameter root message cache + 1) power) + rest := by
+    unfold messageDeficitMoment
+    rw [← Finset.add_sum_erase _ _ (Finset.mem_univ message)]
+    apply congrArg₂ (· + ·)
+    · rw [messageDeficitScore_cacheQuery _ _ _ _ hfinite _ _ hfresh, if_pos hat]
+      split_ifs <;> rfl
+    · apply Finset.sum_congr rfl
+      intro other hother
+      rw [messageDeficitScore_cacheQuery _ _ _ _ hfinite _ _ hfresh,
+        if_neg (fun h => (Finset.mem_erase.mp hother).1 (h.unique hat))]
+  simp_rw [hafter, mul_add, ENNReal.tsum_add, ENNReal.tsum_mul_right, tsum_probOutput_of_liftM_PMF, one_mul]
+  rw [expected_admissible_choice, hbefore]
+  exact (add_le_add hshift le_rfl).trans_eq (add_right_comm _ _ rest)
+
+private theorem expected_messageDeficitMoment_other (parameter : PublicParameter) (root : Digest)
+    (cache : QueryCache HashSpec) (hfinite : Finite cache) (input : HashInput) (hfresh : cache input = none)
+    (hother : ¬∃ message, MessageInputAt parameter root message input) (power : Nat) :
+    (∑' output, Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] *
+      messageDeficitMoment parameter root (cache.cacheQuery input output) power) = messageDeficitMoment parameter root cache power := by
+  have heq (output : HashOutput) : messageDeficitMoment parameter root (cache.cacheQuery input output) power = messageDeficitMoment parameter root cache power := by
+    unfold messageDeficitMoment
+    apply Finset.sum_congr rfl
+    intro message _
+    rw [messageDeficitScore_cacheQuery _ _ _ _ hfinite _ _ hfresh, if_neg (fun h => hother ⟨message, h⟩)]
+  simp_rw [heq, ENNReal.tsum_mul_right, tsum_probOutput_of_liftM_PMF, one_mul]
+
+theorem expected_messageDeficitMoment_second_le (parameter : PublicParameter) (root : Digest)
+    (cache : QueryCache HashSpec) (hfinite : Finite cache) (input : HashInput) (hfresh : cache input = none) :
+    (∑' output, Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] *
+      messageDeficitMoment parameter root (cache.cacheQuery input output) 2) ≤ messageDeficitMoment parameter root cache 2 + 1023 := by
+  by_cases hat : ∃ message, MessageInputAt parameter root message input
+  · obtain ⟨message, hat⟩ := hat
+    exact expected_messageDeficitMoment_at parameter root message cache hfinite input hfresh hat 2 1023
+      (messageDeficit_secondMoment_ennreal _)
+  · rw [expected_messageDeficitMoment_other parameter root cache hfinite input hfresh hat]
+    exact le_self_add
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/MessageDeficitMomentGrowth.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/MessageDeficitMomentGrowth.lean
new file mode 100644
index 000000000..d57e368e8
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/MessageDeficitMomentGrowth.lean
@@ -0,0 +1,49 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.MessageDeficitScore
+
+/-! ## AdmissibleHashMoments -/
+
+namespace SphincsSecurity
+
+open OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+
+noncomputable def positiveScoreMoment (score : ℝ) (power : Nat) : ENNReal :=
+  ENNReal.ofReal (max score 0 ^ power)
+
+theorem positiveScoreMoment_ne_top (score : ℝ) (power : Nat) : positiveScoreMoment score power ≠ ⊤ := by
+  exact ENNReal.ofReal_ne_top
+
+theorem positiveScoreMoment_zero_of_nonpos (score : ℝ) (hscore : score ≤ 0) (power : Nat) (hpower : power ≠ 0) :
+    positiveScoreMoment score power = 0 := by
+  simp [positiveScoreMoment, max_eq_right hscore, zero_pow hpower]
+
+end SphincsSecurity
+
+namespace SphincsSecurity
+
+open OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+
+noncomputable def messageDeficitMoment (parameter : PublicParameter) (root : Digest)
+    (cache : QueryCache HashSpec) (power : Nat) : ENNReal :=
+  ∑ message : Message, positiveScoreMoment (messageDeficitScore parameter root message cache) power
+
+theorem positiveScoreMoment_le_messageDeficitMoment (parameter : PublicParameter) (root : Digest)
+    (cache : QueryCache HashSpec) (power : Nat) (message : Message) :
+    positiveScoreMoment (messageDeficitScore parameter root message cache) power ≤
+      messageDeficitMoment parameter root cache power := by
+  unfold messageDeficitMoment
+  exact Finset.single_le_sum (s := Finset.univ)
+    (f := fun message : Message => positiveScoreMoment (messageDeficitScore parameter root message cache) power)
+    (fun _ _ => zero_le) (Finset.mem_univ message)
+
+theorem messageDeficitMoment_zero_of_no_inputs (parameter : PublicParameter) (root : Digest)
+    (cache : QueryCache HashSpec) (hcount : ∀ message, cachedMessageEntryCount cache parameter root message = 0)
+    (power : Nat) (hpower : power ≠ 0) : messageDeficitMoment parameter root cache power = 0 := by
+  apply Finset.sum_eq_zero
+  intro message _
+  exact positiveScoreMoment_zero_of_nonpos _
+    (messageDeficitScore_of_no_inputs parameter root message cache (hcount message)) power hpower
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/MessageDeficitScore.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/MessageDeficitScore.lean
new file mode 100644
index 000000000..55205c591
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/MessageDeficitScore.lean
@@ -0,0 +1,51 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.MessageAdmissibleDeficit
+namespace SphincsSecurity
+
+open OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+
+theorem cachedMessageEntryCount_ne_top_of_finite (parameter : PublicParameter) (root : Digest) (message : Message)
+    (cache : QueryCache HashSpec) (hfinite : Finite cache) :
+    cachedMessageEntryCount cache parameter root message ≠ ⊤ := by
+  apply ne_top_of_le_ne_top _ (cachedMessageEntryCount_le_enncard cache parameter root message)
+  rw [← hfinite.cachedInputs_ncard_toENNReal_eq_enncard]
+  finiteness
+
+theorem cachedMessageEntryCountWhere_ne_top_of_finite (parameter : PublicParameter) (root : Digest) (message : Message)
+    (cache : QueryCache HashSpec) (hfinite : Finite cache) (P : Concrete.FewTimeView → Prop) :
+    cachedMessageEntryCountWhere cache parameter root message P ≠ ⊤ := by
+  apply ne_top_of_le_ne_top _ (cachedMessageEntryCountWhere_le_enncard cache parameter root message P)
+  rw [← hfinite.cachedInputs_ncard_toENNReal_eq_enncard]
+  finiteness
+
+noncomputable def messageDeficitScore (parameter : PublicParameter) (root : Digest) (message : Message)
+    (cache : QueryCache HashSpec) : ℝ :=
+  (cachedMessageEntryCount cache parameter root message).toReal -
+    1024 * (cachedMessageEntryCountWhere cache parameter root message (fun _ => True)).toReal
+
+theorem messageDeficitScore_of_no_inputs (parameter : PublicParameter) (root : Digest) (message : Message)
+    (cache : QueryCache HashSpec) (hcount : cachedMessageEntryCount cache parameter root message = 0) :
+    messageDeficitScore parameter root message cache ≤ 0 := by
+  simp only [messageDeficitScore, hcount, ENNReal.toReal_zero, zero_sub]
+  exact neg_nonpos.mpr (mul_nonneg (by norm_num) ENNReal.toReal_nonneg)
+
+theorem messageDeficitScore_ofReal_eq (key : SecretKey) (message : Message)
+    (cache : QueryCache HashSpec) (hfinite : Finite cache) :
+    ENNReal.ofReal (messageDeficitScore key.parameter key.root message cache) =
+      1024 * Concrete.messageAdmissibleDeficit key message cache := by
+  have hcount := cachedMessageEntryCount_ne_top_of_finite key.parameter key.root message cache hfinite
+  have hadmissible := cachedMessageEntryCountWhere_ne_top_of_finite key.parameter key.root message cache hfinite (fun _ => True)
+  rw [messageDeficitScore, ENNReal.ofReal_sub _ (mul_nonneg (by norm_num) ENNReal.toReal_nonneg),
+    ENNReal.ofReal_mul (by norm_num), ENNReal.ofReal_toReal hcount, ENNReal.ofReal_toReal hadmissible]
+  norm_num only [ENNReal.ofReal_ofNat]
+  unfold Concrete.messageAdmissibleDeficit
+  rw [ENNReal.mul_sub (by intros; finiteness)]
+  norm_num [ftsTreeHeight]
+  congr 1
+  calc
+    _ = cachedMessageEntryCount cache key.parameter key.root message * ((1024 : ENNReal)⁻¹ * 1024) := by
+      rw [ENNReal.inv_mul_cancel (by norm_num) (by finiteness), mul_one]
+    _ = _ := by ring
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/MessageDigestHazard.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/MessageDigestHazard.lean
new file mode 100644
index 000000000..c1f25e580
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/MessageDigestHazard.lean
@@ -0,0 +1,124 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CachedDigestRate
+import SphincsSecurity.Proof.Fts.FewTimeWeightedOriginRace
+import SphincsSecurity.Proof.Fts.FreshDigestHazard
+import SphincsSecurity.Proof.Fts.MessageCacheCountGrowth
+import SphincsSecurity.Proof.Fts.MessageInputMiss
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+noncomputable local instance instSampleableTypeRandomness_6 : SampleableType Randomness := SampleableType.ofFintype Randomness
+
+attribute [local irreducible] signAttempt signDigestAttemptPrefix signDigestLoop
+
+theorem probEvent_signDigestAttemptPrefix_fresh_ge_messageMiss
+    (key : SecretKey) (message : Message) (reference cache : QueryCache HashSpec) (hreference : reference ≤ cache) :
+    messageInputMissProbability key message cache * ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ ≤
+      Pr[FreshDigestAttempt reference key message | signDigestAttemptPrefix key message cache] := by
+  rw [signDigestAttemptPrefix]
+  apply mul_le_probEvent_bind
+  · exact le_rfl
+  · intro randomness _ hmiss
+    have hrefMiss : reference (tweakableHashInput key.parameter .message
+        (messageDigestPayload key.root message randomness)) = none := by
+      cases hc : reference (tweakableHashInput key.parameter .message (messageDigestPayload key.root message randomness)) with
+      | none => rfl
+      | some output => simpa only [hmiss, reduceCtorEq] using hreference hc
+    rw [show (fun result => pure (randomness, result)) = pure ∘ fun result => (randomness, result) from rfl,
+      probEvent_bind_pure_comp]
+    change ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ ≤
+      Pr[fun result => reference (tweakableHashInput key.parameter .message
+        (messageDigestPayload key.root message randomness)) = none ∧ result.1 ≠ none |
+        (simulateQ (randomOracle : QueryImpl HashSpec _) (signAttempt key message randomness)).run cache]
+    simpa only [hrefMiss, true_and] using (probEvent_signAttempt_fresh_success_eq key message randomness cache hmiss).ge
+
+theorem digestAttemptExpectation_mul_message_rate_le_freshSelection
+    (attempts : Nat) (key : SecretKey) (message : Message) (reference cache : QueryCache HashSpec)
+    (hreference : reference ≤ cache) (budget rate : ENNReal)
+    (hrate : rate ≤ (1 - budget * ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹) * ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹)
+    (hbudget : cachedMessageEntryCount cache key.parameter key.root message + (attempts : ENNReal) ≤ budget) :
+    digestAttemptExpectation attempts key message cache * rate ≤
+      Pr[fun result => freshSelectedLoopView? reference key message result ≠ none |
+        (simulateQ romImpl (signDigestLoop attempts key message)).run cache] := by
+  induction attempts generalizing cache with
+  | zero => simp only [digestAttemptExpectation, zero_mul]; exact zero_le
+  | succ attempts ih =>
+      rw [digestAttemptExpectation, add_mul, one_mul, ← ENNReal.tsum_mul_right, probEvent_signDigestLoop_fresh_recurrence]
+      apply add_le_add
+      · apply hrate.trans (le_trans ?_ (probEvent_signDigestAttemptPrefix_fresh_ge_messageMiss key message reference cache hreference))
+        rw [messageInputMissProbability_eq_count]
+        exact mul_le_mul' (tsub_le_tsub_left (mul_le_mul' (le_self_add.trans hbudget) le_rfl) _) le_rfl
+      · apply ENNReal.tsum_le_tsum
+        intro result
+        by_cases hr : result ∈ support (signDigestAttemptPrefix key message cache)
+        · by_cases hnone : result.2.1 = none
+          · rw [if_pos hnone, if_pos hnone, mul_assoc]
+            apply mul_le_mul' le_rfl
+            apply ih result.2.2 (hreference.trans (signDigestAttemptPrefix_cache_le key message cache result hr))
+            have hgrowth := signAttempt_cachedMessageEntryCount_le key message result.1 cache result.2
+              (signDigestAttemptPrefix_support_attempt key message cache result hr)
+            calc
+              _ ≤ (cachedMessageEntryCount cache key.parameter key.root message + 1) + (attempts : ENNReal) :=
+                add_le_add hgrowth le_rfl
+              _ = cachedMessageEntryCount cache key.parameter key.root message + ((attempts + 1 : Nat) : ENNReal) := by
+                push_cast; ring
+              _ ≤ _ := hbudget
+          · simp only [if_neg hnone, mul_zero, zero_mul, le_refl]
+        · simp only [probOutput_eq_zero_of_not_mem_support hr, zero_mul, le_refl]
+
+noncomputable def messageDigestFreshRate (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) : ENNReal :=
+  (1 - (cachedMessageEntryCount cache key.parameter key.root message + (digestAttemptLimit : ENNReal)) *
+    ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹) * ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹
+
+noncomputable def messageDigestReuseWeight (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) : ENNReal :=
+  ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ / messageDigestFreshRate key message cache
+
+theorem messageDigestFreshRate_ge_budget (key : SecretKey) (message : Message) (cache : QueryCache HashSpec)
+    (q : Nat) (hcache : QueryCache.enncard cache ≤ q) :
+    (1 - ((q + digestAttemptLimit : Nat) : ENNReal) * ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹) *
+      ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ ≤ messageDigestFreshRate key message cache := by
+  unfold messageDigestFreshRate
+  rw [Nat.cast_add]
+  exact mul_le_mul' (tsub_le_tsub_left (mul_le_mul' (add_le_add
+    ((cachedMessageEntryCount_le_enncard cache key.parameter key.root message).trans hcache) le_rfl) le_rfl) _) le_rfl
+
+theorem messageDigestFreshRate_ne_zero (key : SecretKey) (message : Message) (cache : QueryCache HashSpec)
+    (q : Nat) (hq : q ≤ 2 ^ 127) (hcache : QueryCache.enncard cache ≤ q) :
+    messageDigestFreshRate key message cache ≠ 0 := by
+  apply ne_zero_of_lt (lt_of_lt_of_le (pos_iff_ne_zero.mpr ?_) (messageDigestFreshRate_ge_budget key message cache q hcache))
+  apply digestRaceSuccessRate_ne_zero_of_budget_lt
+  norm_num [digestAttemptLimit, randomnessBits] at *
+  omega
+
+theorem messageDigestFreshRate_ne_top (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) :
+    messageDigestFreshRate key message cache ≠ ⊤ := by
+  unfold messageDigestFreshRate
+  finiteness
+
+theorem messageDigestReuseWeight_le (key : SecretKey) (message : Message) (cache : QueryCache HashSpec)
+    (q : Nat) (hcache : QueryCache.enncard cache ≤ q) :
+    messageDigestReuseWeight key message cache ≤ digestReuseWeight q :=
+  ENNReal.div_le_div_left (messageDigestFreshRate_ge_budget key message cache q hcache) _
+
+theorem messageDigestReuseWeight_ne_top (key : SecretKey) (message : Message) (cache : QueryCache HashSpec)
+    (q : Nat) (hq : q ≤ 2 ^ 127) (hcache : QueryCache.enncard cache ≤ q) :
+    messageDigestReuseWeight key message cache ≠ ⊤ :=
+  ne_top_of_le_ne_top (digestReuseWeight_ne_top q hq) (messageDigestReuseWeight_le key message cache q hcache)
+
+theorem exactDigestReuseWeight_le_fresh_mul_messageReuseWeight
+    (key : SecretKey) (message : Message) (cache : QueryCache HashSpec)
+    (q : Nat) (hq : q ≤ 2 ^ 127) (hcache : QueryCache.enncard cache ≤ q) :
+    exactDigestReuseWeight key message cache ≤ freshDigestSelectionProbability key message cache * messageDigestReuseWeight key message cache := by
+  have hcancel : messageDigestFreshRate key message cache * messageDigestReuseWeight key message cache =
+      ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ := by
+    unfold messageDigestReuseWeight
+    rw [div_eq_mul_inv, mul_left_comm, ENNReal.mul_inv_cancel
+      (messageDigestFreshRate_ne_zero key message cache q hq hcache) (messageDigestFreshRate_ne_top key message cache), mul_one]
+  have h := mul_le_mul' (digestAttemptExpectation_mul_message_rate_le_freshSelection digestAttemptLimit key message cache cache le_rfl
+    (cachedMessageEntryCount cache key.parameter key.root message + (digestAttemptLimit : ENNReal))
+    (messageDigestFreshRate key message cache) le_rfl le_rfl) (le_refl (messageDigestReuseWeight key message cache))
+  rw [mul_assoc, hcancel] at h
+  exact h
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/MessageInputMiss.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/MessageInputMiss.lean
new file mode 100644
index 000000000..2df3457c1
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/MessageInputMiss.lean
@@ -0,0 +1,67 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.MessagePrehit
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+noncomputable local instance instSampleableTypeRandomness_4 : SampleableType Randomness := SampleableType.ofFintype Randomness
+
+theorem uniform_randomness_messageInput_cacheHit_eq_count
+    (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) :
+    Pr[fun randomness : Randomness => ∃ output,
+      cache (tweakableHashInput key.parameter .message (messageDigestPayload key.root message randomness)) = some output |
+      ($ᵗ Randomness : ProbComp Randomness)] =
+      cachedMessageEntryCount cache key.parameter key.root message * ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ := by
+  let hit : Randomness → Prop := fun randomness => ∃ output,
+    cache (tweakableHashInput key.parameter .message (messageDigestPayload key.root message randomness)) = some output
+  let targets : Finset Randomness := Finset.univ.filter hit
+  let fiber := cachedMessageInputSet cache key.parameter key.root message
+  let embedding : (targets : Set Randomness) ↪ fiber :=
+    ⟨fun randomness =>
+      ⟨⟨tweakableHashInput key.parameter .message (messageDigestPayload key.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 <|
+        (messageDigestPayload_injective key.root <|
+          (tweakableHashInput_injective key.parameter (by trivial) (by trivial) <|
+            congrArg (fun entry : fiber => entry.1.1) heq).2).2⟩
+  have hsurjective : Function.Surjective embedding := by
+    rintro ⟨⟨input, output⟩, hcached, randomness, hinput⟩
+    change input = tweakableHashInput key.parameter .message (messageDigestPayload key.root message randomness) at hinput
+    subst input
+    have hh : hit randomness := ⟨output, hcached⟩
+    let target : (targets : Set Randomness) := ⟨randomness, Finset.mem_filter.mpr ⟨Finset.mem_univ _, hh⟩⟩
+    refine ⟨target, Subtype.ext ?_⟩
+    have hout := Option.some.inj ((Classical.choose_spec (Finset.mem_filter.mp target.2).2).symm.trans hcached)
+    exact Sigma.ext (by rfl) (heq_of_eq hout)
+  have hcard : (targets.card : ENNReal) = cachedMessageEntryCount cache key.parameter key.root message := by
+    have h := Set.encard_congr (Equiv.ofBijective embedding ⟨embedding.injective, hsurjective⟩)
+    simpa only [cachedMessageEntryCount, fiber, Set.encard_coe_eq_coe_finsetCard, ENat.toENNReal_coe] using
+      congrArg ENat.toENNReal h
+  rw [probEvent_uniformSample, card_randomness, div_eq_mul_inv]
+  change (targets.card : ENNReal) * ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ = _
+  rw [hcard]
+
+noncomputable def messageInputMissProbability (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) : ENNReal :=
+  Pr[fun randomness : Randomness => cache (tweakableHashInput key.parameter .message
+    (messageDigestPayload key.root message randomness)) = none | ($ᵗ Randomness : ProbComp Randomness)]
+
+theorem messageInputMissProbability_eq_count (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) :
+    messageInputMissProbability key message cache =
+      1 - cachedMessageEntryCount cache key.parameter key.root message * ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ := by
+  let miss : Randomness → Prop := fun randomness => cache (tweakableHashInput key.parameter .message
+    (messageDigestPayload key.root message randomness)) = none
+  have hnot : Pr[fun randomness => ¬ miss randomness | ($ᵗ Randomness : ProbComp Randomness)] =
+      cachedMessageEntryCount cache key.parameter key.root message * ((2 ^ randomnessBits : Nat) : ENNReal)⁻¹ := by
+    apply Eq.trans ?_ (uniform_randomness_messageInput_cacheHit_eq_count key message cache)
+    apply probEvent_congr'
+    · intro randomness _
+      exact Option.ne_none_iff_exists'
+    · rfl
+  have h := probEvent_compl ($ᵗ Randomness : ProbComp Randomness) miss
+  rw [probFailure_of_liftM_PMF, tsub_zero] at h
+  have heq := ENNReal.eq_sub_of_add_eq probEvent_ne_top h
+  rw [hnot] at heq
+  exact heq
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/MessageNormalizedReuse.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/MessageNormalizedReuse.lean
new file mode 100644
index 000000000..ab45056a7
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/MessageNormalizedReuse.lean
@@ -0,0 +1,60 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.MessageDigestHazard
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+
+noncomputable def normalizedMessageReuseWeight (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) : ENNReal :=
+  messageDigestReuseWeight key message cache /
+    (1 + cachedMessageEntryCountWhere cache key.parameter key.root message (fun _ => True) * messageDigestReuseWeight key message cache)
+
+theorem normalizedMessageReuseWeight_eq_inv (key : SecretKey) (message : Message) (cache : QueryCache HashSpec)
+    (q : Nat) (hq : q ≤ 2 ^ 127) (hcache : QueryCache.enncard cache ≤ q) :
+    normalizedMessageReuseWeight key message cache =
+      (cachedMessageEntryCountWhere cache key.parameter key.root message (fun _ => True) +
+        messageDigestFreshRate key message cache * ((2 ^ randomnessBits : Nat) : ENNReal))⁻¹ := by
+  let count := cachedMessageEntryCountWhere cache key.parameter key.root message (fun _ => True)
+  let reuse := messageDigestReuseWeight key message cache
+  have hreuseTop : reuse ≠ ⊤ := messageDigestReuseWeight_ne_top key message cache q hq hcache
+  have hreuseZero : reuse ≠ 0 := by
+    unfold reuse messageDigestReuseWeight
+    rw [div_eq_mul_inv]
+    exact mul_ne_zero (ENNReal.inv_ne_zero.mpr (by finiteness))
+      (ENNReal.inv_ne_zero.mpr (messageDigestFreshRate_ne_top key message cache))
+  have hinv : reuse⁻¹ = messageDigestFreshRate key message cache * ((2 ^ randomnessBits : Nat) : ENNReal) := by
+    unfold reuse messageDigestReuseWeight
+    rw [div_eq_mul_inv, ENNReal.mul_inv (Or.inl (ENNReal.inv_ne_zero.mpr (by finiteness)))
+      (Or.inl (ENNReal.inv_ne_top.mpr (by positivity))), inv_inv, inv_inv, mul_comm]
+  have hfactor : 1 + count * reuse = reuse * (count + reuse⁻¹) := by
+    rw [mul_add, ENNReal.mul_inv_cancel hreuseZero hreuseTop]
+    ring
+  change reuse * (1 + count * reuse)⁻¹ = _
+  rw [hfactor, ENNReal.mul_inv (Or.inl hreuseZero) (Or.inl hreuseTop), ← mul_assoc,
+    ENNReal.mul_inv_cancel hreuseZero hreuseTop, one_mul, hinv]
+
+theorem exactDigestReuseWeight_le_normalizedMessage (key : SecretKey) (message : Message) (cache : QueryCache HashSpec)
+    (q : Nat) (hq : q ≤ 2 ^ 127) (hcache : QueryCache.enncard cache ≤ q) :
+    exactDigestReuseWeight key message cache ≤ normalizedMessageReuseWeight key message cache := by
+  have hcount : cachedMessageEntryCountWhere cache key.parameter key.root message (fun _ => True) ≠ ⊤ :=
+    ne_top_of_le_ne_top (by finiteness)
+      ((cachedMessageEntryCountWhere_le_enncard cache key.parameter key.root message (fun _ => True)).trans hcache)
+  have hreuse := messageDigestReuseWeight_ne_top key message cache q hq hcache
+  have hmass : freshDigestSelectionProbability key message cache +
+      cachedMessageEntryCountWhere cache key.parameter key.root message (fun _ => True) * exactDigestReuseWeight key message cache ≤ 1 :=
+    le_self_add.trans_eq (freshSelection_add_count_exactWeight_add_exhaustion key message cache)
+  unfold normalizedMessageReuseWeight
+  apply (ENNReal.le_div_iff_mul_le (Or.inl (by positivity)) (Or.inl (by finiteness))).mpr
+  calc
+    _ = exactDigestReuseWeight key message cache +
+        (cachedMessageEntryCountWhere cache key.parameter key.root message (fun _ => True) * exactDigestReuseWeight key message cache) *
+          messageDigestReuseWeight key message cache := by ring
+    _ ≤ freshDigestSelectionProbability key message cache * messageDigestReuseWeight key message cache +
+        (cachedMessageEntryCountWhere cache key.parameter key.root message (fun _ => True) * exactDigestReuseWeight key message cache) *
+          messageDigestReuseWeight key message cache :=
+      add_le_add (exactDigestReuseWeight_le_fresh_mul_messageReuseWeight key message cache q hq hcache) le_rfl
+    _ = (freshDigestSelectionProbability key message cache +
+        cachedMessageEntryCountWhere cache key.parameter key.root message (fun _ => True) * exactDigestReuseWeight key message cache) *
+          messageDigestReuseWeight key message cache := by rw [add_mul]
+    _ ≤ _ := mul_le_of_le_one_left' hmass
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/MessagePrehit.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/MessagePrehit.lean
new file mode 100644
index 000000000..8fdb547ac
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/MessagePrehit.lean
@@ -0,0 +1,125 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Scheme.NoMessage
+import SphincsSecurity.Proof.Scheme.Replay
+/-!
+# 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 instSampleableTypeRandomness : 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 × (IndexGroup → FtsLeaf)) × QueryCache HashSpec) :
+    ProbComp (Option (Randomness × Index × (IndexGroup → 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 × (IndexGroup → 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 × (IndexGroup → FtsLeaf))))) =
+        simulateQ randomOracle
+          (Concrete.signAttempt secretKey message randomness :
+            OracleComp HashSpec (Option (Index × (IndexGroup → FtsLeaf)))) := by
+    change simulateQ (unifFwdImpl HashSpec + randomOracle)
+        (liftM (Concrete.signAttempt secretKey message randomness :
+          OracleComp HashSpec (Option (Index × (IndexGroup → 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 × (IndexGroup → 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]
+
+theorem Concrete.signAfterDigest_some_randomness (f : QueryImpl HashSpec Id)
+    (secretKey : SecretKey) (randomness : Randomness) (index : Index)
+    (leaves : IndexGroup → 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 : IndexGroup → 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
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/NearCertificateBound.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/NearCertificateBound.lean
new file mode 100644
index 000000000..b3a80a016
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/NearCertificateBound.lean
@@ -0,0 +1,41 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FixedProposalMoments
+import SphincsSecurity.Proof.Fts.TerminalProposalEnvelope
+
+namespace SphincsSecurity.Concrete
+
+open ENNReal
+
+set_option maxHeartbeats 2000000 in
+theorem stirlingPowerMoment_thirteen :
+    stirlingPowerMoment (19 / 50) 13 =
+      (1986585224814431503899382459 : ENNReal) / 12207031250000000000000 := by
+  unfold stirlingPowerMoment
+  apply (ENNReal.toReal_eq_toReal_iff' (ENNReal.sum_ne_top.mpr (fun _ _ => by finiteness)) (by finiteness)).mp
+  simp (disch := finiteness) only [ENNReal.toReal_sum, ENNReal.toReal_mul,
+    ENNReal.toReal_pow, ENNReal.toReal_div, ENNReal.toReal_natCast, ENNReal.toReal_ofNat]
+  norm_num [Finset.sum_range_succ, Nat.stirlingSecond]
+
+/-- The average price, over a uniform proposal word of the fixed length, of a certificate that covers thirteen of the fourteen trees. -/
+theorem uniformWordAverage_nearPrice (required : Finset FtsTree) (hdegree : required.card = 13) :
+    uniformWordAverage fixedProposalLength (terminalCertificatePrice required) ≤
+      ((557 : ENNReal) / 14) / (2 ^ 128 : Nat) := by
+  have hprice : terminalCertificatePrice required = fun word =>
+      ((((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ * (Fintype.card Index : ENNReal)⁻¹) * targetCertificateScale required) *
+        proposalPowerSum required.card word := by
+    funext word
+    unfold terminalCertificatePrice proposalPowerSum
+    ring
+  rw [hprice, uniformWordAverage_mul_left]
+  refine (mul_le_mul' le_rfl (uniformWordAverage_powerSum_le (α := Index) fixedProposalLength required.card (19 / 50)
+    fixedProposalLength_rate_le)).trans ?_
+  rw [hdegree, stirlingPowerMoment_thirteen]
+  unfold targetCertificateScale
+  rw [hdegree]
+  have hindex : Fintype.card Index = 2 ^ 26 := Fintype.card_fin _
+  have hleaf : Fintype.card FtsLeaf = 2 ^ 10 := Fintype.card_fin _
+  rw [hindex, hleaf]
+  apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp
+  norm_num [ftsTreeHeight, ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_div, ENNReal.toReal_pow]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/NewTargetEnvelopeCharge.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/NewTargetEnvelopeCharge.lean
new file mode 100644
index 000000000..108597cfe
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/NewTargetEnvelopeCharge.lean
@@ -0,0 +1,36 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.ConcreteTargetShapeSigning
+import SphincsSecurity.Proof.Fts.TargetShapeEnvelope
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (MessageHashInput)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def newTargetEnvelopeCharge (key : SecretKey) (before after : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (uniform reuse arrival : ENNReal) (queries signings : Nat)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) : ENNReal :=
+  cacheMessageWeight key.parameter (fun input target => if before input = none then
+    targetShapeEnvelope uniform reuse arrival queries signings (targetShapeMoments key after log (payloadOf input) target) groups remaining else 0) after
+
+theorem newTargetEnvelopeCharge_of_no_new (key : SecretKey) (before after : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (uniform reuse arrival : ENNReal) (queries signings : Nat)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree)
+    (hnone : ∀ payload output, before (tweakableHashInput key.parameter .message payload) = none →
+      after (tweakableHashInput key.parameter .message payload) = some output → ¬ Admissible (truncateMessageDigest output)) :
+    newTargetEnvelopeCharge key before after log uniform reuse arrival queries signings groups remaining = 0 := by
+  apply ENNReal.tsum_eq_zero.mpr
+  intro input
+  unfold cacheMessageEntryWeight
+  cases houtput : after input with
+  | none => rfl
+  | some output =>
+      simp only
+      split_ifs with hgood hfresh
+      · obtain ⟨payload, rfl⟩ := hgood.1
+        exact (hnone payload output hfresh houtput hgood.2).elim
+      · rfl
+      · rfl
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/NormalizedTargetCacheQuery.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/NormalizedTargetCacheQuery.lean
new file mode 100644
index 000000000..e60941e33
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/NormalizedTargetCacheQuery.lean
@@ -0,0 +1,89 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CachedTargetSubsetMatch
+import SphincsSecurity.Proof.Fts.NormalizedTargetMatches
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def normalizedCachedTargetSubsetMatch (parameter : PublicParameter) (cache : QueryCache HashSpec)
+    (targetInput : HashInput) (target : FewTimeView) (required : Finset FtsTree) : ENNReal :=
+  (Fintype.card FtsLeaf ^ required.card : Nat) * cachedTargetSubsetMatch parameter cache targetInput target required
+
+noncomputable def normalizedTargetCacheProduct (parameter : PublicParameter) (cache : QueryCache HashSpec)
+    (targetInput : HashInput) (target : FewTimeView) (groups : Fin m → Finset FtsTree) : ENNReal :=
+  ∏ slot : Fin m, normalizedCachedTargetSubsetMatch parameter cache targetInput target (groups slot)
+
+theorem normalizedCachedTargetSubsetMatch_eq_weight (parameter : PublicParameter) (cache : QueryCache HashSpec)
+    (targetInput : HashInput) (target : FewTimeView) (required : Finset FtsTree) :
+    normalizedCachedTargetSubsetMatch parameter cache targetInput target required =
+      cacheMessageWeight parameter (fun input source => if input = targetInput then 0 else normalizedSourceSubsetMatch target source required) cache := by
+  unfold normalizedCachedTargetSubsetMatch cachedTargetSubsetMatch
+  rw [mul_comm, ← cacheMessageWeight_mul_right]
+  congr 1
+  funext input source
+  split_ifs <;> simp only [normalizedSourceSubsetMatch, zero_mul, mul_comm]
+
+theorem normalizedCachedTargetSubsetMatch_cacheQuery (parameter : PublicParameter) (before : QueryCache HashSpec)
+    (targetInput : HashInput) (target : FewTimeView) (required : Finset FtsTree) (input : HashInput) (output : HashOutput)
+    (hfresh : before input = none) (hmessage : FtsProbeSimulation.MessageHashInput parameter input) (hne : input ≠ targetInput) :
+    normalizedCachedTargetSubsetMatch parameter (before.cacheQuery input output) targetInput target required =
+      normalizedCachedTargetSubsetMatch parameter before targetInput target required +
+        if Admissible (truncateMessageDigest output) then normalizedSourceSubsetMatch target (hashOutputFewTimeView output) required else 0 := by
+  simp only [normalizedCachedTargetSubsetMatch, cachedTargetSubsetMatch_cacheQuery parameter before targetInput target required input output hfresh,
+    hmessage, true_and, if_neg hne, mul_add, mul_ite, mul_zero, normalizedSourceSubsetMatch]
+
+theorem normalizedTargetCacheProduct_cacheQuery (parameter : PublicParameter) (before : QueryCache HashSpec)
+    (targetInput : HashInput) (target : FewTimeView) (groups : Fin m → Finset FtsTree)
+    (input : HashInput) (output : HashOutput)
+    (hfresh : before input = none) (hmessage : FtsProbeSimulation.MessageHashInput parameter input) (hne : input ≠ targetInput) :
+    normalizedTargetCacheProduct parameter (before.cacheQuery input output) targetInput target groups =
+      normalizedTargetCacheProduct parameter before targetInput target groups +
+        ∑ selected ∈ (Finset.univ : Finset (Fin m)).powerset.erase ∅,
+          (if Admissible (truncateMessageDigest output) then
+            ∏ slot ∈ selected, normalizedSourceSubsetMatch target (hashOutputFewTimeView output) (groups slot) else 0) *
+              ∏ slot ∈ (Finset.univ : Finset (Fin m)) \ selected, normalizedCachedTargetSubsetMatch parameter before targetInput target (groups slot) := by
+  unfold normalizedTargetCacheProduct
+  simp only [normalizedCachedTargetSubsetMatch_cacheQuery parameter before targetInput target _ input output hfresh hmessage hne]
+  rw [show (∏ slot : Fin m, (normalizedCachedTargetSubsetMatch parameter before targetInput target (groups slot) +
+      if Admissible (truncateMessageDigest output) then normalizedSourceSubsetMatch target (hashOutputFewTimeView output) (groups slot) else 0)) =
+      ∏ slot : Fin m, ((if Admissible (truncateMessageDigest output) then normalizedSourceSubsetMatch target (hashOutputFewTimeView output) (groups slot) else 0) +
+        normalizedCachedTargetSubsetMatch parameter before targetInput target (groups slot)) by simp only [add_comm]]
+  rw [Finset.prod_add, ← Finset.add_sum_erase _ _ (Finset.empty_mem_powerset _)]
+  simp only [Finset.prod_empty, Finset.sdiff_empty, one_mul]
+  congr 1
+  apply Finset.sum_congr rfl
+  intro selected hselected
+  congr 1
+  by_cases hadmissible : Admissible (truncateMessageDigest output)
+  · simp only [hadmissible, if_true]
+  · simp only [hadmissible, if_false]
+    obtain ⟨slot, hslot⟩ := Finset.nonempty_iff_ne_empty.mpr (Finset.mem_erase.mp hselected).1
+    exact Finset.prod_eq_zero hslot rfl
+
+theorem expected_normalizedTargetCacheProduct_cacheQuery (parameter : PublicParameter) (before : QueryCache HashSpec)
+    (targetInput : HashInput) (target : FewTimeView) (groups : Fin m → Finset FtsTree)
+    (hgroups : ∀ slot, (groups slot).Nonempty) (hdisjoint : Pairwise (fun i j => Disjoint (groups i) (groups j)))
+    (input : HashInput) (hfresh : before input = none)
+    (hmessage : FtsProbeSimulation.MessageHashInput parameter input) (hne : input ≠ targetInput) :
+    (∑' output, Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] *
+      normalizedTargetCacheProduct parameter (before.cacheQuery input output) targetInput target groups) =
+      normalizedTargetCacheProduct parameter before targetInput target groups +
+        (((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ * (Fintype.card Index : ENNReal)⁻¹) *
+          ∑ selected ∈ (Finset.univ : Finset (Fin m)).powerset.erase ∅,
+            ∏ slot ∈ (Finset.univ : Finset (Fin m)) \ selected, normalizedCachedTargetSubsetMatch parameter before targetInput target (groups slot) := by
+  have hmass : (∑' output, Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)]) = 1 := tsum_probOutput_eq_one' (by simp)
+  simp only [normalizedTargetCacheProduct_cacheQuery parameter before targetInput target groups input _ hfresh hmessage hne,
+    mul_add, ENNReal.tsum_add, ENNReal.tsum_mul_right, hmass, one_mul, Finset.mul_sum]
+  rw [Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)]
+  congr 1
+  apply Finset.sum_congr rfl
+  intro selected hselected
+  simp only [← mul_assoc, ENNReal.tsum_mul_right]
+  congr 1
+  exact expected_hash_normalizedSourceSubsetMatch_prod target groups selected
+    (Finset.nonempty_iff_ne_empty.mpr (Finset.mem_erase.mp hselected).1)
+    (fun slot _ => hgroups slot) (fun i _ j _ hij => hdisjoint hij)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/NormalizedTargetLogSigning.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/NormalizedTargetLogSigning.lean
new file mode 100644
index 000000000..3c5ef37b2
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/NormalizedTargetLogSigning.lean
@@ -0,0 +1,70 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.NormalizedTargetCacheQuery
+import SphincsSecurity.Proof.Fts.TargetMixedGrowthPolynomial
+import SphincsSecurity.Proof.Fts.TargetSigningMatchFactors
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (messageAnswers)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def normalizedTargetLogIncrement (key : SecretKey) (cache : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView) (required : Finset FtsTree) (source : FewTimeView) : ENNReal :=
+  ∑ selected ∈ required.powerset.erase ∅, normalizedSourceSubsetMatch target source selected *
+    normalizedTargetLogProduct key cache log payload target (required \ selected)
+
+theorem normalizedTargetLogProduct_add_increment (key : SecretKey) (cache : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView) (required : Finset FtsTree) (source : FewTimeView) :
+    normalizedTargetLogProduct key cache log payload target required + normalizedTargetLogIncrement key cache log payload target required source =
+      ∏ tree ∈ required, (normalizedTargetLogMatch key cache log payload target tree + normalizedSourceSubsetMatch target source {tree}) := by
+  rw [targetLogProduct_insert_expansion, ← Finset.add_sum_erase _ _ (Finset.empty_mem_powerset required)]
+  simp only [normalizedSourceSubsetMatch, Finset.card_empty, pow_zero, Nat.cast_one, sourceSubsetMatch,
+    Finset.prod_empty, Nat.cast_one, one_mul, Finset.sdiff_empty, normalizedTargetLogIncrement, normalizedTargetLogProduct]
+
+theorem normalizedTargetLogProduct_append_none (key : SecretKey) (before after : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (entry : SigningEntry) (payload : HashInput) (target : FewTimeView) (required : Finset FtsTree)
+    (hcache : before ≤ after) (hsigned : SigningDigestsCached key.parameter before key.root log)
+    (hnone : eligibleSigningView? (messageAnswers key.parameter after) key.root payload entry = none) :
+    normalizedTargetLogProduct key after (log ++ [entry]) payload target required =
+      normalizedTargetLogProduct key before log payload target required := by
+  apply Finset.prod_congr rfl
+  intro tree _
+  have hstep := targetTreeMatchCount_log_append_singleton log entry
+    (eligibleSigningView? (messageAnswers key.parameter after) key.root payload) target tree
+  change targetTreeMatchCount (eligibleSigningViews (messageAnswers key.parameter after) key.root payload (log ++ [entry])) target tree =
+    targetTreeMatchCount (eligibleSigningViews (messageAnswers key.parameter after) key.root payload log) target tree + _ at hstep
+  simp only [hnone, reduceCtorEq, false_and, exists_false, if_false, add_zero,
+    eligibleSigningViews_cache_stable key before after log payload hcache hsigned] at hstep
+  exact congrArg (fun count : Nat => (Fintype.card FtsLeaf : ENNReal) * (count : ENNReal)) hstep
+
+theorem expected_normalizedTargetLogIncrement (key : SecretKey) (cache : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView) (required : Finset FtsTree) :
+    (∑' source, Pr[= source | ($ᵗ FewTimeView : ProbComp FewTimeView)] * normalizedTargetLogIncrement key cache log payload target required source) =
+      (Fintype.card Index : ENNReal)⁻¹ * ∑ selected ∈ required.powerset.erase ∅,
+        normalizedTargetLogProduct key cache log payload target (required \ selected) := by
+  simp only [normalizedTargetLogIncrement, Finset.mul_sum]
+  rw [Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)]
+  apply Finset.sum_congr rfl
+  intro selected hselected
+  simp only [← mul_assoc, ENNReal.tsum_mul_right]
+  rw [expected_normalizedSourceSubsetMatch target selected
+    (Finset.nonempty_iff_ne_empty.mpr (Finset.mem_erase.mp hselected).1)]
+
+theorem cached_normalizedTargetLogIncrement (key : SecretKey) (cache : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView) (required : Finset FtsTree) :
+    cacheMessageWeight key.parameter (fun input source => if input = tweakableHashInput key.parameter .message payload then 0
+      else normalizedTargetLogIncrement key cache log payload target required source) cache =
+      ∑ selected ∈ required.powerset.erase ∅,
+        normalizedCachedTargetSubsetMatch key.parameter cache (tweakableHashInput key.parameter .message payload) target selected *
+          normalizedTargetLogProduct key cache log payload target (required \ selected) := by
+  have hpoint (input : HashInput) (source : FewTimeView) :
+      (if input = tweakableHashInput key.parameter .message payload then 0 else normalizedTargetLogIncrement key cache log payload target required source) =
+      ∑ selected ∈ required.powerset.erase ∅,
+        (if input = tweakableHashInput key.parameter .message payload then 0 else normalizedSourceSubsetMatch target source selected) *
+          normalizedTargetLogProduct key cache log payload target (required \ selected) := by
+    unfold normalizedTargetLogIncrement
+    split_ifs <;> simp only [zero_mul, Finset.sum_const_zero]
+  simp only [hpoint, cacheMessageWeight_sum, cacheMessageWeight_mul_right, normalizedCachedTargetSubsetMatch_eq_weight]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/NormalizedTargetMatches.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/NormalizedTargetMatches.lean
new file mode 100644
index 000000000..942183566
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/NormalizedTargetMatches.lean
@@ -0,0 +1,66 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FutureCoverageBound
+import SphincsSecurity.Proof.Fts.SubsetTargetExpectation
+
+/-! ## TargetCacheProductQuery -/
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem sourceSubsetMatch_prod (target source : FewTimeView) (groups : Fin m → Finset FtsTree) (selected : Finset (Fin m)) :
+    (∏ slot ∈ selected, sourceSubsetMatch target source (groups slot)) =
+      sourceSubsetMatch target source (selected.biUnion groups) := by
+  induction selected using Finset.induction_on with
+  | empty => simp [sourceSubsetMatch]
+  | @insert slot selected hnot ih =>
+      rw [Finset.prod_insert hnot, Finset.biUnion_insert, ih, sourceSubsetMatch_mul]
+
+end SphincsSecurity.Concrete
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def normalizedSourceSubsetMatch (target source : FewTimeView) (required : Finset FtsTree) : ENNReal :=
+  (Fintype.card FtsLeaf ^ required.card : Nat) * (sourceSubsetMatch target source required : ENNReal)
+
+theorem normalizedSourceSubsetMatch_prod (target source : FewTimeView) (groups : Fin m → Finset FtsTree)
+    (selected : Finset (Fin m)) (hdisjoint : (selected : Set (Fin m)).PairwiseDisjoint groups) :
+    (∏ slot ∈ selected, normalizedSourceSubsetMatch target source (groups slot)) =
+      normalizedSourceSubsetMatch target source (selected.biUnion groups) := by
+  simp only [normalizedSourceSubsetMatch, Finset.prod_mul_distrib, ← Nat.cast_prod,
+    Finset.prod_pow_eq_pow_sum, sourceSubsetMatch_prod, Finset.card_biUnion hdisjoint]
+
+theorem expected_normalizedSourceSubsetMatch (target : FewTimeView) (required : Finset FtsTree) (hne : required.Nonempty) :
+    (∑' source, Pr[= source | ($ᵗ FewTimeView : ProbComp FewTimeView)] * normalizedSourceSubsetMatch target source required) =
+      (Fintype.card Index : ENNReal)⁻¹ := by
+  simp only [normalizedSourceSubsetMatch, mul_left_comm (Pr[= _ | ($ᵗ FewTimeView : ProbComp FewTimeView)]), ENNReal.tsum_mul_left]
+  exact normalized_expected_sourceSubsetMatch target required hne
+
+theorem expected_normalizedSourceSubsetMatch_prod (target : FewTimeView) (groups : Fin m → Finset FtsTree)
+    (selected : Finset (Fin m)) (hselected : selected.Nonempty) (hgroups : ∀ slot ∈ selected, (groups slot).Nonempty)
+    (hdisjoint : (selected : Set (Fin m)).PairwiseDisjoint groups) :
+    (∑' source, Pr[= source | ($ᵗ FewTimeView : ProbComp FewTimeView)] *
+      ∏ slot ∈ selected, normalizedSourceSubsetMatch target source (groups slot)) = (Fintype.card Index : ENNReal)⁻¹ := by
+  simp only [normalizedSourceSubsetMatch_prod target _ groups selected hdisjoint]
+  obtain ⟨slot, hslot⟩ := hselected
+  obtain ⟨tree, htree⟩ := hgroups slot hslot
+  exact expected_normalizedSourceSubsetMatch target _ ⟨tree, Finset.mem_biUnion.mpr ⟨slot, hslot, htree⟩⟩
+
+theorem expected_hash_normalizedSourceSubsetMatch_prod (target : FewTimeView) (groups : Fin m → Finset FtsTree)
+    (selected : Finset (Fin m)) (hselected : selected.Nonempty) (hgroups : ∀ slot ∈ selected, (groups slot).Nonempty)
+    (hdisjoint : (selected : Set (Fin m)).PairwiseDisjoint groups) :
+    (∑' output, Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] *
+      (if Admissible (truncateMessageDigest output) then
+        ∏ slot ∈ selected, normalizedSourceSubsetMatch target (hashOutputFewTimeView output) (groups slot) else 0)) =
+      ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ * (Fintype.card Index : ENNReal)⁻¹ := by
+  rw [expected_uniformHashOutput_admissible_weight
+    (fun source => ∏ slot ∈ selected, normalizedSourceSubsetMatch target source (groups slot)),
+    expected_normalizedSourceSubsetMatch_prod target groups selected hselected hgroups hdisjoint]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/ObservedAdaptiveCoverBound.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/ObservedAdaptiveCoverBound.lean
new file mode 100644
index 000000000..516959715
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/ObservedAdaptiveCoverBound.lean
@@ -0,0 +1,20 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.JointProbeMessageAnswers
+import SphincsSecurity.Proof.Fts.ObservedFreshCoverBound
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (messageAnswers)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def fixedSigningViews (parameter : PublicParameter) (cache : QueryCache HashSpec)
+    (root : Digest) (log : QueryLog SigningSpec) (input : HashInput) : Fin log.length → Option FewTimeView :=
+  eligibleSigningViews (messageAnswers parameter cache) root (payloadOf input) log
+
+def SigningDigestsCached (parameter : PublicParameter) (cache : QueryCache HashSpec)
+    (root : Digest) (log : QueryLog SigningSpec) : Prop :=
+  ∀ entry ∈ log, ∀ signature, entry.2 = some signature →
+    messageAnswers parameter cache (messageDigestPayload root entry.1 signature.randomness) ≠ none
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/ObservedFreshCoverBound.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/ObservedFreshCoverBound.lean
new file mode 100644
index 000000000..b0e364fb6
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/ObservedFreshCoverBound.lean
@@ -0,0 +1,35 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FewTimeUniform
+
+/-! ## ObservedCoverPattern -/
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+def observedSigningView? (answers : HashInput → Option HashOutput) (root : Digest) (entry : SigningEntry) : Option FewTimeView := do
+  let signature ← entry.2
+  let answer ← answers (messageDigestPayload root entry.1 signature.randomness)
+  pure (hashOutputFewTimeView answer)
+
+end SphincsSecurity.Concrete
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def eligibleSigningView? (answers : HashInput → Option HashOutput) (root : Digest)
+    (targetPayload : HashInput) (entry : SigningEntry) : Option FewTimeView := do
+  let signature ← entry.2
+  if messageDigestPayload root entry.1 signature.randomness = targetPayload then none
+  else observedSigningView? answers root entry
+
+noncomputable def eligibleSigningViews (answers : HashInput → Option HashOutput) (root : Digest)
+    (targetPayload : HashInput) (log : QueryLog SigningSpec) : Fin log.length → Option FewTimeView :=
+  fun slot => eligibleSigningView? answers root targetPayload (log.get slot)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/ObservedOccupancy.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/ObservedOccupancy.lean
new file mode 100644
index 000000000..4b42ef524
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/ObservedOccupancy.lean
@@ -0,0 +1,49 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FewTimeConditionalCoverage
+import SphincsSecurity.Proof.Fts.ObservedAdaptiveCoverBound
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (messageAnswers)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+def observedOptionalSigningViews (answers : HashInput → Option HashOutput) (root : Digest)
+    (log : QueryLog SigningSpec) : Fin log.length → Option FewTimeView :=
+  fun slot => observedSigningView? answers root (log.get slot)
+
+theorem observedSigningView?_cache_stable (parameter : PublicParameter) (root : Digest)
+    (before after : QueryCache HashSpec) (hcache : before ≤ after) (entry : SigningEntry)
+    (hsigned : ∀ signature, entry.2 = some signature →
+      messageAnswers parameter before (messageDigestPayload root entry.1 signature.randomness) ≠ none) :
+    observedSigningView? (messageAnswers parameter after) root entry = observedSigningView? (messageAnswers parameter before) root entry := by
+  cases hresponse : entry.2 with
+  | none => simp [observedSigningView?, hresponse]
+  | some signature =>
+      obtain ⟨output, houtput⟩ := Option.ne_none_iff_exists'.mp (hsigned signature hresponse)
+      have hafter : messageAnswers parameter after (messageDigestPayload root entry.1 signature.randomness) = some output := hcache houtput
+      simp [observedSigningView?, hresponse, houtput, hafter]
+
+theorem observedOptionalSigningViews_cache_stable (parameter : PublicParameter) (root : Digest)
+    (before after : QueryCache HashSpec) (log : QueryLog SigningSpec)
+    (hcache : before ≤ after) (hsigned : SigningDigestsCached parameter before root log) :
+    observedOptionalSigningViews (messageAnswers parameter after) root log =
+      observedOptionalSigningViews (messageAnswers parameter before) root log := by
+  funext slot
+  exact observedSigningView?_cache_stable parameter root before after hcache (log.get slot) (hsigned _ (List.get_mem _ _))
+
+theorem signingSlotsAtIndex_log_card {α : Type} (log : List α) (view : α → Option FewTimeView) (index : Index) :
+    (signingSlotsAtIndex (fun slot => view (log.get slot)) index).card =
+      (log.map (fun entry => if ∃ source, view entry = some source ∧ source.1 = index then 1 else 0)).sum := by
+  rw [signingSlotsAtIndex, Finset.card_eq_sum_ones, Finset.sum_filter, ← List.sum_ofFn]
+  exact congrArg List.sum (List.ofFn_getElem_eq_map log
+    (fun entry => if ∃ source, view entry = some source ∧ source.1 = index then 1 else 0))
+
+theorem signingSlotsAtIndex_log_append_card {α : Type} (log : List α) (entry : α)
+    (view : α → Option FewTimeView) (index : Index) :
+    (signingSlotsAtIndex (fun slot => view ((log ++ [entry]).get slot)) index).card =
+      (signingSlotsAtIndex (fun slot => view (log.get slot)) index).card +
+        if ∃ source, view entry = some source ∧ source.1 = index then 1 else 0 := by
+  simp only [signingSlotsAtIndex_log_card, List.map_append, List.map_cons, List.map_nil, List.sum_append, List.sum_cons, List.sum_nil, add_zero]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/OriginalCacheExceptionBound.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/OriginalCacheExceptionBound.lean
new file mode 100644
index 000000000..cf663a275
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/OriginalCacheExceptionBound.lean
@@ -0,0 +1,296 @@
+import SphincsSecurity.Proof.Fts.OriginalMessageAllocation
+import SphincsSecurity.Proof.Reference.ReferencePrimitiveBound
+import SphincsSecurity.Proof.Fts.CertificateCacheExceptionKernels
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] scheme certificateCacheExceptionWeight expectedBoundaryMessageCalls
+  certificateCacheLengthImpl certificateLengthImpl certificateCacheProposalImpl
+
+noncomputable def originalCacheHistoryWeight (key : SecretKey) (state : CertificateCacheMonitorState) : ENNReal :=
+  if state.2.2 then 1 else certificateCacheExceptionWeight key state.1
+
+private theorem probOutput_probCompLift {Result : Type} (computation : ProbComp Result) (result : Result) :
+    Pr[= result | (liftM computation : PMF Result)] = Pr[= result | computation] := rfl
+
+theorem expected_certificateCacheLengthImpl_of_record_function (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateCacheMonitorState)
+    (counter : CertificateCacheMonitorState → ENNReal) (weight : ProposalExecutionRecord input → ENNReal)
+    (hadvance : ∀ length record, counter
+      (originalProposalAdvance (certificateCacheMonitorUpdate key budget required stopAfter) input state length record) = weight record) :
+    (∑' result, Pr[= result | (certificateCacheLengthImpl key budget required stopAfter input).run state] * counter result.2) =
+      ∑' record, Pr[= record | originalProposalRecord key input state.1] * weight record := by
+  simp only [certificateCacheLengthImpl, originalLengthImpl, lengthRecordImpl, StateT.run_mk]
+  split
+  · rw [← PMF.monad_map_eq_map, tsum_probOutput_map_mul]
+    simp only [hadvance]
+    have h := congrArg (fun law : PMF (ProposalExecutionRecord input) =>
+      ∑' record, Pr[= record | law] * weight record)
+      (recordLengthBridge_record (originalProposalRecord key input state.1)
+        targetProposalAcceptance targetProposalAcceptance_ne_zero targetProposalAcceptance_lt_one.le)
+    rw [← PMF.monad_map_eq_map, tsum_probOutput_map_mul] at h
+    exact h
+  · rw [← PMF.monad_map_eq_map, tsum_probOutput_map_mul]
+    simp only [hadvance]
+
+theorem certificateCacheLengthImpl_original_cache (key : SecretKey) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : CertificateStopRule) (input : (OracleWorld + SigningSpec).Domain) (state : CertificateCacheMonitorState) :
+    (fun result => (result.1, result.2.1)) <$> (certificateCacheLengthImpl key budget required stopAfter input).run state =
+      (liftM ((simulateQ romImpl (expandedAdversaryImpl key input)).run state.1) : PMF _) := by
+  have h := congrArg (Functor.map (fun result => (result.1, result.2.1)))
+    (certificateCacheLengthImpl_project key budget required stopAfter input state)
+  simp only [Functor.map_map] at h
+  exact h.trans (certificateLengthImpl_original_cache key budget required stopAfter input (certificateCacheMonitorProject state))
+
+theorem certificateCacheLengthImpl_finite (key : SecretKey) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : CertificateStopRule) (input : (OracleWorld + SigningSpec).Domain) (state : CertificateCacheMonitorState)
+    (hfinite : Finite state.1) (result : (OracleWorld + SigningSpec).Range input × CertificateCacheMonitorState)
+    (hr : result ∈ ((certificateCacheLengthImpl key budget required stopAfter input).run state).support) :
+    Finite result.2.1 := by
+  have hm := (PMF.mem_support_map_iff (fun result => (result.1, result.2.1)) _ _).mpr ⟨result, hr, rfl⟩
+  rw [← PMF.monad_map_eq_map, certificateCacheLengthImpl_original_cache, probCompLift_support] at hm
+  exact finite_cache_of_mem_support (expandedAdversaryImpl key input) state.1 result.1 result.2.1 hm hfinite
+
+theorem expected_originalProposalRecord_cacheWeight (key : SecretKey) (input : (OracleWorld + SigningSpec).Domain)
+    (cache : QueryCache HashSpec) (hfinite : Finite cache) :
+    (∑' record, Pr[= record | originalProposalRecord key input cache] * certificateCacheExceptionWeight key record.cache) ≤
+      certificateCacheExceptionWeight key cache +
+        expectedBoundaryMessageCalls key.parameter (expandedAdversaryImpl key input) cache * certificateCacheExceptionRate := by
+  have h := congrArg (fun law => ∑' result, Pr[= result | law] * certificateCacheExceptionWeight key result.2)
+    (originalProposalRecord_boundary key input cache)
+  rw [← PMF.monad_map_eq_map, tsum_probOutput_map_mul] at h
+  simp only [probOutput_probCompLift] at h
+  rw [expectedBoundaryMessageCalls]
+  exact h.le.trans (expected_certificateCacheExceptionWeight_boundary key (expandedAdversaryImpl key input) cache hfinite)
+
+theorem expected_originalCacheHistoryWeight_step (key : SecretKey) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : CertificateStopRule) (input : (OracleWorld + SigningSpec).Domain) (state : CertificateCacheMonitorState)
+    (hfinite : Finite state.1) :
+    (∑' result, Pr[= result | (certificateCacheLengthImpl key budget required stopAfter input).run state] *
+      originalCacheHistoryWeight key result.2) ≤ originalCacheHistoryWeight key state +
+        expectedBoundaryMessageCalls key.parameter (expandedAdversaryImpl key input) state.1 * certificateCacheExceptionRate := by
+  rw [expected_certificateCacheLengthImpl_of_record_function key budget required stopAfter input state
+    (originalCacheHistoryWeight key)
+    (fun record => if state.2.2 || decide (CertificateCacheExceptional key state.1) ||
+      decide (CertificateCacheExceptional key record.cache) then 1 else certificateCacheExceptionWeight key record.cache)
+    (fun _ _ => rfl)]
+  by_cases hhit : state.2.2 = true
+  · simp only [hhit, Bool.true_or, if_true, mul_one, tsum_probOutput_of_liftM_PMF, originalCacheHistoryWeight]
+    exact le_self_add
+  · by_cases hbad : CertificateCacheExceptional key state.1
+    · simp only [hbad, decide_true, Bool.or_true, Bool.true_or, if_true, mul_one, tsum_probOutput_of_liftM_PMF,
+        originalCacheHistoryWeight, hhit, Bool.false_eq_true, if_false]
+      exact (certificateCacheExceptionWeight_bad key state.1 hfinite hbad).trans le_self_add
+    · simp only [hhit, Bool.false_or, hbad, decide_false, originalCacheHistoryWeight]
+      apply le_trans _ (expected_originalProposalRecord_cacheWeight key input state.1 hfinite)
+      apply ENNReal.tsum_le_tsum
+      intro record
+      by_cases hr : record ∈ (originalProposalRecord key input state.1).support
+      · apply mul_le_mul' le_rfl
+        split_ifs with hbadRecord
+        · have hb := originalProposalRecord_boundary_support key input state.1 record hr
+          have hm : (record.output, record.cache) ∈ support ((simulateQ romImpl (expandedAdversaryImpl key input)).run state.1) := by
+            rw [← boundaryRun_forget key.parameter (expandedAdversaryImpl key input) state.1, support_map]
+            exact ⟨((record.output, record.trace), record.cache), hb, rfl⟩
+          exact certificateCacheExceptionWeight_bad key record.cache
+            (finite_cache_of_mem_support (expandedAdversaryImpl key input) state.1 record.output record.cache hm hfinite)
+            (of_decide_eq_true hbadRecord)
+        · exact le_rfl
+      · have hz : originalProposalRecord key input state.1 record = 0 := by
+          simpa only [PMF.mem_support_iff, not_not] using hr
+        rw [PMF.probOutput_eq_apply, hz, zero_mul, zero_mul]
+
+theorem expected_originalCacheHistoryWeight_run {Result : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) (state : CertificateCacheMonitorState)
+    (hfinite : Finite state.1) :
+    (∑' result, Pr[= result | (simulateQ (certificateCacheLengthImpl key budget required stopAfter) computation).run state] *
+      originalCacheHistoryWeight key result.2) ≤ originalCacheHistoryWeight key state +
+        expectedBoundaryMessageCalls key.parameter (simulateQ (expandedAdversaryImpl key) computation) state.1 *
+          certificateCacheExceptionRate := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value =>
+      simp only [simulateQ_pure, StateT.run_pure, tsum_probOutput_pure_mul, expectedBoundaryMessageCalls_pure,
+        zero_mul, add_zero, le_refl]
+  | query_bind input next ih =>
+      rw [simulateQ_bind, simulateQ_spec_query, StateT.run_bind, tsum_probOutput_bind_mul,
+        simulateQ_bind, simulateQ_spec_query, expectedBoundaryMessageCalls_bind]
+      have hproject := congrArg (fun law => ∑' result, Pr[= result | law] *
+        expectedBoundaryMessageCalls key.parameter (simulateQ (expandedAdversaryImpl key) (next result.1)) result.2)
+        (certificateCacheLengthImpl_original_cache key budget required stopAfter input state)
+      rw [tsum_probOutput_map_mul] at hproject
+      simp only [probOutput_probCompLift] at hproject
+      calc
+        _ ≤ ∑' result, Pr[= result | (certificateCacheLengthImpl key budget required stopAfter input).run state] *
+            (originalCacheHistoryWeight key result.2 +
+              expectedBoundaryMessageCalls key.parameter (simulateQ (expandedAdversaryImpl key) (next result.1)) result.2.1 *
+                certificateCacheExceptionRate) := by
+          apply ENNReal.tsum_le_tsum
+          intro result
+          by_cases hr : result ∈ ((certificateCacheLengthImpl key budget required stopAfter input).run state).support
+          · exact mul_le_mul' le_rfl (ih result.1 result.2
+              (certificateCacheLengthImpl_finite key budget required stopAfter input state hfinite result hr))
+          · have hz : (certificateCacheLengthImpl key budget required stopAfter input).run state result = 0 := by
+              simpa only [PMF.mem_support_iff, not_not] using hr
+            rw [PMF.probOutput_eq_apply, hz, zero_mul, zero_mul]
+        _ = (∑' result, Pr[= result | (certificateCacheLengthImpl key budget required stopAfter input).run state] *
+              originalCacheHistoryWeight key result.2) +
+            (∑' result, Pr[= result | (certificateCacheLengthImpl key budget required stopAfter input).run state] *
+              expectedBoundaryMessageCalls key.parameter (simulateQ (expandedAdversaryImpl key) (next result.1)) result.2.1) *
+                certificateCacheExceptionRate := by
+          simp only [mul_add, ENNReal.tsum_add, ← mul_assoc, ENNReal.tsum_mul_right]
+        _ ≤ (originalCacheHistoryWeight key state +
+              expectedBoundaryMessageCalls key.parameter (expandedAdversaryImpl key input) state.1 * certificateCacheExceptionRate) +
+            (∑' result, Pr[= result | (certificateCacheLengthImpl key budget required stopAfter input).run state] *
+              expectedBoundaryMessageCalls key.parameter (simulateQ (expandedAdversaryImpl key) (next result.1)) result.2.1) *
+                certificateCacheExceptionRate :=
+          add_le_add (expected_originalCacheHistoryWeight_step key budget required stopAfter input state hfinite) le_rfl
+        _ = _ := by rw [hproject]; ring
+
+theorem certificateCacheLength_hit_le_message_cost {Result : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) (state : CertificateCacheMonitorState)
+    (hfinite : Finite state.1) :
+    Pr[fun result => result.2.2.2 = true |
+      (simulateQ (certificateCacheLengthImpl key budget required stopAfter) computation).run state] ≤
+      originalCacheHistoryWeight key state +
+        expectedBoundaryMessageCalls key.parameter (simulateQ (expandedAdversaryImpl key) computation) state.1 *
+          certificateCacheExceptionRate := by
+  apply le_trans _ (expected_originalCacheHistoryWeight_run key budget required stopAfter computation state hfinite)
+  rw [probEvent_eq_tsum_ite]
+  apply ENNReal.tsum_le_tsum
+  intro result
+  by_cases hhit : result.2.2.2 = true
+  · simp only [hhit, if_true, originalCacheHistoryWeight, mul_one, le_refl]
+  · simp only [hhit]
+    exact bot_le
+
+theorem certificateCacheProposal_hit_le_message_cost {Result : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) (state : List Index × CertificateCacheMonitorState)
+    (hfinite : Finite state.2.1) :
+    Pr[fun result => result.2.2.2.2 = true |
+      (simulateQ (certificateCacheProposalImpl key budget required stopAfter) computation).run state] ≤
+      originalCacheHistoryWeight key state.2 +
+        expectedBoundaryMessageCalls key.parameter (simulateQ (expandedAdversaryImpl key) computation) state.2.1 *
+          certificateCacheExceptionRate := by
+  have h := certificateCacheLength_hit_le_message_cost key budget required stopAfter computation state.2 hfinite
+  rw [← simulateQ_certificateCacheProposalImpl_length key budget required stopAfter computation state, probEvent_map] at h
+  exact h
+
+private theorem expected_probCompLift_of_map_eq {Source Result : Type}
+    (source : ProbComp Source) (result : ProbComp Result) (project : Source → Result)
+    (hproject : project <$> source = result) (cost : Result → ENNReal) :
+    (∑' value, Pr[= value | (liftM source : PMF Source)] * cost (project value)) =
+      ∑' value, Pr[= value | result] * cost value := by
+  rw [← hproject, tsum_probOutput_map_mul]
+  simp only [probOutput_probCompLift]
+
+theorem certificateContextGame_cache_hit_le_original_message (adversary : Adversary) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : SecretKey → CertificateStopRule) (stopped : Bool) :
+    Pr[fun result => result.2.2.2.2.2 = true | certificateContextGame adversary budget required stopAfter stopped] ≤
+      originalCertificateMessageCost adversary * certificateCacheExceptionRate := by
+  rw [certificateContextGame, probEvent_bind_eq_tsum]
+  calc
+    _ ≤ ∑' generated, Pr[= generated | (liftM (boundaryRun 0 scheme.keygen ∅) : PMF _)] *
+        (expectedBoundaryMessageCalls generated.1.1.2.parameter
+          (simulateQ (expandedAdversaryImpl generated.1.1.2)
+            (FtsProbeSimulation.retainedGameRestComputation adversary generated.1.1.1)) generated.2 * certificateCacheExceptionRate) := by
+      apply ENNReal.tsum_le_tsum
+      intro generated
+      by_cases hg : generated ∈ (liftM (boundaryRun 0 scheme.keygen ∅) : PMF _).support
+      · have hb : generated ∈ support (boundaryRun 0 scheme.keygen ∅) := (probCompLift_support _ ▸ hg)
+        have hn : (generated.1.1, generated.2) ∈ support ((simulateQ romImpl scheme.keygen).run ∅) := by
+          rw [← boundaryRun_forget 0 scheme.keygen ∅, support_map]
+          exact ⟨generated, hb, rfl⟩
+        have hf := finite_cache_of_mem_support scheme.keygen ∅ generated.1.1 generated.2 hn finite_empty
+        have hzero : originalCacheHistoryWeight generated.1.1.2
+            (generated.2, initialCertificateMonitor generated.1.2.hashCalls stopped, false) = 0 := by
+          rw [originalCacheHistoryWeight, if_neg Bool.false_ne_true]
+          exact certificateCacheExceptionWeight_initial generated.1.1.2 generated.2
+            (keygen_cache_message_none (generated.1.1, generated.2) hn)
+        have h := certificateCacheProposal_hit_le_message_cost generated.1.1.2 budget required
+          (stopAfter generated.1.1.2) (FtsProbeSimulation.retainedGameRestComputation adversary generated.1.1.1)
+          ([], generated.2, initialCertificateMonitor generated.1.2.hashCalls stopped, false) hf
+        rw [hzero, zero_add] at h
+        apply mul_le_mul' le_rfl
+        simpa only [bind_pure_comp, probEvent_map, Function.comp_def] using h
+      · have hz : (liftM (boundaryRun 0 scheme.keygen ∅) : PMF _) generated = 0 := by
+          simpa only [PMF.mem_support_iff, not_not] using hg
+        rw [PMF.probOutput_eq_apply, hz, zero_mul, zero_mul]
+    _ = (∑' generated, Pr[= generated | (liftM (boundaryRun 0 scheme.keygen ∅) : PMF _)] *
+        expectedBoundaryMessageCalls generated.1.1.2.parameter
+          (simulateQ (expandedAdversaryImpl generated.1.1.2)
+            (FtsProbeSimulation.retainedGameRestComputation adversary generated.1.1.1)) generated.2) * certificateCacheExceptionRate := by
+      simp only [← mul_assoc, ENNReal.tsum_mul_right]
+    _ = _ := by
+      apply congrArg (· * certificateCacheExceptionRate)
+      exact expected_probCompLift_of_map_eq (boundaryRun 0 scheme.keygen ∅)
+        ((simulateQ romImpl scheme.keygen).run ∅) (fun result => (result.1.1, result.2))
+        (boundaryRun_forget 0 scheme.keygen ∅) (fun generated =>
+          expectedBoundaryMessageCalls generated.1.2.parameter
+            (simulateQ (expandedAdversaryImpl generated.1.2)
+              (FtsProbeSimulation.retainedGameRestComputation adversary generated.1.1)) generated.2)
+
+theorem certificateContextGame_exception_le_cache_add_prefix (adversary : Adversary) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : SecretKey → CertificateStopRule) (stopped : Bool) :
+    Pr[fun result => CertificateGameExceptional result.2 | certificateContextGame adversary budget required stopAfter stopped] ≤
+      Pr[fun result => result.2.2.2.2.2 = true | certificateContextGame adversary budget required stopAfter stopped] +
+      Pr[fun result => ProposalPrefixExceptional result.2.2.2.2.1.proposals result.2.2.2.2.1.log.length |
+        certificateContextGame adversary budget required stopAfter stopped] :=
+  probEvent_or_le (certificateContextGame adversary budget required stopAfter stopped) _ _
+
+theorem originalCertificateSource_full_le_original_message_add_prefix (adversary : Adversary) (q : Nat)
+    (hbudget : q ≤ 2 ^ 127) (hbound : HasHashQueryBound scheme adversary q) :
+    Pr[OriginalFullCertificate | originalCertificateSource adversary] ≤
+      ((2 ^ 128 : ENNReal)⁻¹ + certificateCacheExceptionRate) * originalCertificateMessageCost adversary +
+      (q : ENNReal) * (11 / 2 ^ 144 : ENNReal) +
+      Pr[fun result => ProposalPrefixExceptional result.2.2.2.2.1.proposals result.2.2.2.2.1.log.length |
+        certificateContextGame adversary q Finset.univ (fun _ => proposalPrefixStop) false] := by
+  have he := (certificateContextGame_exception_le_cache_add_prefix adversary q Finset.univ (fun _ => proposalPrefixStop) false).trans
+    (add_le_add (certificateContextGame_cache_hit_le_original_message adversary q Finset.univ (fun _ => proposalPrefixStop) false) le_rfl)
+  apply (originalCertificateSource_full_le_original_message_add_exception adversary q hbudget hbound).trans
+  calc
+    _ ≤ (2 ^ 128 : ENNReal)⁻¹ * originalCertificateMessageCost adversary + (q : ENNReal) * (11 / 2 ^ 144 : ENNReal) +
+        (originalCertificateMessageCost adversary * certificateCacheExceptionRate +
+          Pr[fun result => ProposalPrefixExceptional result.2.2.2.2.1.proposals result.2.2.2.2.1.log.length |
+            certificateContextGame adversary q Finset.univ (fun _ => proposalPrefixStop) false]) := add_le_add le_rfl he
+    _ = _ := by ring
+
+theorem original_primitive_add_full_certificate_le_small_budget_add_prefix (dummy : OtsReferenceWords)
+    (adversary : Adversary) (q : Nat) (hbound : HasHashQueryBound scheme adversary q)
+    (hsmall : q ≤ 3 * 2 ^ 114) :
+    Pr[GraphPrimitiveEvent dummy | referenceGraphContextGame contactObserver (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] +
+      Pr[OriginalFullCertificate | originalCertificateSource adversary] ≤
+      (7 / 4 : ENNReal) * ((q : ENNReal) / 2 ^ 128) + (q : ENNReal) * (11 / 2 ^ 144 : ENNReal) +
+      Pr[fun result => ProposalPrefixExceptional result.2.2.2.2.1.proposals result.2.2.2.2.1.log.length |
+        certificateContextGame adversary q Finset.univ (fun _ => proposalPrefixStop) false] := by
+  have hbudget : q ≤ 2 ^ 127 := hsmall.trans (by norm_num)
+  have hcard : Fintype.card Digest = 2 ^ 128 := by simp [digestBits]
+  have hp := referenceGraphContextGame_primitive_small_budget dummy adversary q hbound hsmall
+  rw [hcard] at hp
+  simp only [Nat.cast_pow, Nat.cast_ofNat] at hp
+  have hrate : (2 ^ 128 : ENNReal)⁻¹ + certificateCacheExceptionRate ≤ (7 / 4 : ENNReal) / 2 ^ 128 := by
+    apply (add_le_add le_rfl certificateCacheExceptionRate_le).trans
+    apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp
+    norm_num [ENNReal.toReal_add, ENNReal.toReal_inv, ENNReal.toReal_div]
+  have hc := (originalCertificateSource_full_le_original_message_add_prefix adversary q hbudget hbound).trans
+    (add_le_add (add_le_add (mul_le_mul' hrate (originalCertificateMessageCost_le_referenceRecorded dummy adversary)) le_rfl) le_rfl)
+  calc
+    _ ≤ Pr[GraphPrimitiveEvent dummy | referenceGraphContextGame contactObserver (canonicalGraphGameInputs adversary)
+          (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] +
+        (((7 / 4 : ENNReal) / 2 ^ 128) *
+          (∑' result, Pr[= result | referenceRecordedGame (canonicalGraphGameInputs adversary)
+            (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] * (result.messageCalls : ENNReal)) +
+          (q : ENNReal) * (11 / 2 ^ 144 : ENNReal) +
+          Pr[fun result => ProposalPrefixExceptional result.2.2.2.2.1.proposals result.2.2.2.2.1.log.length |
+            certificateContextGame adversary q Finset.univ (fun _ => proposalPrefixStop) false]) := add_le_add le_rfl hc
+    _ ≤ _ := by
+      rw [← add_assoc, ← add_assoc]
+      exact add_le_add (add_le_add hp le_rfl) le_rfl
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/OriginalCertificateBound.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/OriginalCertificateBound.lean
new file mode 100644
index 000000000..4e8162354
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/OriginalCertificateBound.lean
@@ -0,0 +1,209 @@
+import SphincsSecurity.Proof.Fts.CertificateBankCompleteness
+import SphincsSecurity.Proof.Fts.UnitCertificateCoverage
+import SphincsSecurity.Proof.Fts.CertificateOriginalMessageCost
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (RetainedRestResult retainedGameRestComputation)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] scheme signAfterDigest certificateCacheProposalImpl retainedGameRestComputation
+
+abbrev CertificateContextResult := SecretKey × CertificateCacheGameResult
+abbrev OriginalCertificateResult := SecretKey × RetainedRestResult × QueryCache HashSpec
+
+noncomputable def originalCertificateSource (adversary : Adversary) : ProbComp OriginalCertificateResult := do
+  let generated ← (simulateQ romImpl scheme.keygen).run ∅
+  let result ← (simulateQ (unloggedMappedAdversaryImpl generated.1.2)
+    (retainedGameRestComputation adversary generated.1.1)).run generated.2
+  pure (generated.1.2, result)
+
+noncomputable def certificateContextGame (adversary : Adversary) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : SecretKey → CertificateStopRule) (stopped : Bool) : PMF CertificateContextResult := do
+  let generated ← (liftM (boundaryRun 0 scheme.keygen ∅) : PMF _)
+  let key := generated.1.1.2
+  let result ← (simulateQ (certificateCacheProposalImpl key budget required (stopAfter key))
+    (retainedGameRestComputation adversary generated.1.1.1)).run
+      ([], generated.2, initialCertificateMonitor generated.1.2.hashCalls stopped, false)
+  pure (key, result)
+
+theorem certificateContextGame_project (adversary : Adversary) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : SecretKey → CertificateStopRule) (stopped : Bool) :
+    Prod.snd <$> certificateContextGame adversary budget required stopAfter stopped =
+      certificateCacheGame adversary budget required stopAfter stopped := by
+  simp only [certificateContextGame, certificateCacheGame, map_bind, map_pure, bind_pure]
+
+theorem certificateCacheProposal_original {Result : Type} (key : SecretKey) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : CertificateStopRule) (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : List Index × CertificateCacheMonitorState) :
+    (fun result => (result.1, result.2.2.1)) <$>
+      (simulateQ (certificateCacheProposalImpl key budget required stopAfter) computation).run state =
+        (liftM ((simulateQ (unloggedMappedAdversaryImpl key) computation).run state.2.1) : PMF _) := by
+  rw [certificateCacheProposalImpl]
+  exact simulateQ_originalProposalImpl_original key _ _ _ computation state
+
+def CertificateContextResult.original (result : CertificateContextResult) : OriginalCertificateResult :=
+  (result.1, result.2.1, result.2.2.2.1)
+
+theorem certificateContextGame_original (adversary : Adversary) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : SecretKey → CertificateStopRule) (stopped : Bool) :
+    CertificateContextResult.original <$> certificateContextGame adversary budget required stopAfter stopped =
+      (liftM (originalCertificateSource adversary) : PMF _) := by
+  have hrest (generated : ((PublicKey × SecretKey) × SigningBoundaryTrace) × QueryCache HashSpec) :
+      (fun result : CertificateCacheGameResult => (generated.1.1.2, result.1, result.2.2.1)) <$>
+        (simulateQ (certificateCacheProposalImpl generated.1.1.2 budget required (stopAfter generated.1.1.2))
+          (retainedGameRestComputation adversary generated.1.1.1)).run
+          ([], generated.2, initialCertificateMonitor generated.1.2.hashCalls stopped, false) =
+      (liftM (do
+        let result ← (simulateQ (unloggedMappedAdversaryImpl generated.1.1.2)
+          (retainedGameRestComputation adversary generated.1.1.1)).run generated.2
+        pure (generated.1.1.2, result)) : PMF _) := by
+    have h := congrArg (Functor.map (fun result => (generated.1.1.2, result)))
+      (certificateCacheProposal_original generated.1.1.2 budget required (stopAfter generated.1.1.2)
+        (retainedGameRestComputation adversary generated.1.1.1)
+        ([], generated.2, initialCertificateMonitor generated.1.2.hashCalls stopped, false))
+    simpa only [Functor.map_map, ← liftM_map (m := ProbComp) (n := PMF), bind_pure_comp] using h
+  simp only [certificateContextGame, map_bind, bind_pure_comp, Functor.map_map, CertificateContextResult.original]
+  simp_rw [hrest]
+  rw [← liftM_bind (m := ProbComp) (n := PMF)]
+  apply congrArg (fun computation : ProbComp OriginalCertificateResult => (liftM computation : PMF _))
+  rw [originalCertificateSource, ← boundaryRun_forget 0 scheme.keygen ∅, bind_map_left]
+
+def OriginalFullCertificate (result : OriginalCertificateResult) : Prop :=
+  SigningTranscript.Valid result.2.1.1.2 ∧
+    ∃ input, TargetCertificateAt result.1 Finset.univ (result.2.2, result.2.1.1.2) input
+
+theorem certificateContextGame_full_count (adversary : Adversary) (q : Nat)
+    (hbudget : q ≤ 2 ^ 127) (hbound : HasHashQueryBound scheme adversary q) (result : CertificateContextResult)
+    (hr : result ∈ (certificateContextGame adversary q Finset.univ (fun _ => proposalPrefixStop) false).support)
+    (hfull : OriginalFullCertificate result.original) (hclean : ¬CertificateGameExceptional result.2) :
+    1 ≤ certificateBankCount result.2.2.2.2.1.bank := by
+  rw [certificateContextGame, PMF.monad_bind_eq_bind, PMF.mem_support_bind_iff] at hr
+  obtain ⟨generated, hgenerated, hr⟩ := hr
+  rw [PMF.monad_bind_eq_bind, PMF.mem_support_bind_iff] at hr
+  obtain ⟨output, houtput, hr⟩ := hr
+  rw [PMF.monad_pure_eq_pure, PMF.mem_support_pure_iff] at hr
+  subst result
+  rw [probCompLift_support] at hgenerated
+  have hwhole : (scheme.keygen >>= fun keys => gameRest scheme adversary keys.1 keys.2).IsQueryBoundP
+      (· matches .inr _) q := hbound
+  have hkeygen := boundaryRun_bind_query_bound 0 scheme.keygen
+    (fun keys => gameRest scheme adversary keys.1 keys.2) q hwhole ∅ generated hgenerated
+  have hrest := hkeygen.2
+  rw [OtsProbeSimulation.gameRest_eq_map_retained, isQueryBoundP_map_iff] at hrest
+  have hretained : OtsProbeSimulation.retainedGameRestComputation adversary generated.1.1.1 =
+      retainedGameRestComputation adversary generated.1.1.1 := by
+    unfold OtsProbeSimulation.retainedGameRestComputation retainedGameRestComputation
+    rfl
+  rw [hretained] at hrest
+  have hcache := boundaryRun_enncard_le 0 scheme.keygen ∅ generated hgenerated
+  simp only [QueryCache.enncard_empty, zero_add] at hcache
+  have hg : (generated.1.1, generated.2) ∈ support ((simulateQ romImpl scheme.keygen).run ∅) := by
+    rw [← boundaryRun_forget 0 scheme.keygen ∅, support_map]
+    exact ⟨generated, hgenerated, rfl⟩
+  dsimp only [OriginalFullCertificate, CertificateContextResult.original] at hfull
+  obtain ⟨hvalid, input, hcertificate⟩ := hfull
+  exact certificateCacheProposal_rest_clean_certificate adversary generated.1.1.1 generated.1.1.2
+    q (q - generated.1.2.hashCalls) generated.1.2.hashCalls Finset.univ hbudget hrest generated.2
+    (Nat.add_sub_of_le hkeygen.1).le hcache (keygen_cache_message_none (generated.1.1, generated.2) hg) output houtput hvalid hclean input hcertificate
+
+private theorem probOutput_probCompLift {Result : Type} (computation : ProbComp Result) (result : Result) :
+    Pr[= result | (liftM computation : PMF Result)] = Pr[= result | computation] := rfl
+
+private theorem expected_probCompLift_of_map_eq {Source Result : Type}
+    (source : ProbComp Source) (result : ProbComp Result) (project : Source → Result)
+    (hproject : project <$> source = result) (cost : Result → ENNReal) :
+    (∑' value, Pr[= value | (liftM source : PMF Source)] * cost (project value)) =
+      ∑' value, Pr[= value | result] * cost value := by
+  rw [← hproject, tsum_probOutput_map_mul]
+  simp only [probOutput_probCompLift]
+
+private theorem probEvent_probCompLift {Result : Type} (computation : ProbComp Result) (event : Result → Prop) :
+    Pr[event | (liftM computation : PMF Result)] = Pr[event | computation] := by
+  simp only [probEvent_eq_tsum_ite]
+  rfl
+
+theorem originalCertificateSource_full_le_count_add_exception (adversary : Adversary) (q : Nat)
+    (hbudget : q ≤ 2 ^ 127) (hbound : HasHashQueryBound scheme adversary q) :
+    Pr[OriginalFullCertificate | originalCertificateSource adversary] ≤
+      (∑' result, Pr[= result | certificateContextGame adversary q Finset.univ (fun _ => proposalPrefixStop) false] *
+        certificateBankCount result.2.2.2.2.1.bank) +
+      Pr[fun result => CertificateGameExceptional result.2 |
+        certificateContextGame adversary q Finset.univ (fun _ => proposalPrefixStop) false] := by
+  let law : SPMF CertificateContextResult := liftM (certificateContextGame adversary q Finset.univ (fun _ => proposalPrefixStop) false)
+  have hsource : Pr[OriginalFullCertificate | originalCertificateSource adversary] =
+      Pr[fun result => OriginalFullCertificate result.original | law] := by
+    have h := congrArg (fun source : PMF OriginalCertificateResult => Pr[OriginalFullCertificate | source])
+      (certificateContextGame_original adversary q Finset.univ (fun _ => proposalPrefixStop) false)
+    rw [probEvent_map, probEvent_probCompLift] at h
+    simpa only [law, SPMF.probEvent_liftM, Function.comp_def] using h.symm
+  rw [hsource]
+  change Pr[fun result => OriginalFullCertificate result.original | law] ≤
+    (∑' result, Pr[= result | law] * certificateBankCount result.2.2.2.2.1.bank) +
+    Pr[fun result => CertificateGameExceptional result.2 | law]
+  refine (probEvent_mono (q := fun result =>
+    (OriginalFullCertificate result.original ∧ ¬CertificateGameExceptional result.2) ∨ CertificateGameExceptional result.2)
+      (fun result _ h => by by_cases hc : CertificateGameExceptional result.2; exact Or.inr hc; exact Or.inl ⟨h, hc⟩)).trans
+    ((probEvent_or_le law _ _).trans (add_le_add ?_ le_rfl))
+  apply probEvent_le_tsum_probOutput_mul_cost_of_mem_support
+  intro result hr h
+  exact certificateContextGame_full_count adversary q hbudget hbound result (by simpa only [law, SPMF.support_eq_support, SPMF.support_liftM] using hr) h.1 h.2
+
+theorem originalCertificateSource_full_le_message_add_exception (adversary : Adversary) (q : Nat)
+    (hbudget : q ≤ 2 ^ 127) (hbound : HasHashQueryBound scheme adversary q) :
+    Pr[OriginalFullCertificate | originalCertificateSource adversary] ≤
+      (2 ^ 128 : ENNReal)⁻¹ *
+        (∑' result, Pr[= result | certificateContextGame adversary q Finset.univ (fun _ => proposalPrefixStop) false] *
+          (result.2.2.2.2.1.messageCalls : ENNReal)) + (q : ENNReal) * (11 / 2 ^ 144 : ENNReal) +
+      Pr[fun result => CertificateGameExceptional result.2 |
+        certificateContextGame adversary q Finset.univ (fun _ => proposalPrefixStop) false] := by
+  have h := expected_certificateCacheGame_full_unit_count_le adversary q (fun _ _ _ _ _ => false) hbudget hbound
+  dsimp only at h
+  simp only [Bool.or_false] at h
+  rw [← certificateContextGame_project adversary q Finset.univ (fun _ => proposalPrefixStop) false] at h
+  simp only [tsum_probOutput_map_mul] at h
+  exact (originalCertificateSource_full_le_count_add_exception adversary q hbudget hbound).trans (add_le_add h le_rfl)
+
+noncomputable def originalCertificateMessageCost (adversary : Adversary) : ENNReal :=
+  ∑' generated, Pr[= generated | (simulateQ romImpl scheme.keygen).run ∅] *
+    expectedBoundaryMessageCalls generated.1.2.parameter
+      (simulateQ (expandedAdversaryImpl generated.1.2) (retainedGameRestComputation adversary generated.1.1)) generated.2
+
+theorem certificateContextGame_messageCalls_le_original (adversary : Adversary) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : SecretKey → CertificateStopRule) (stopped : Bool) :
+    (∑' result, Pr[= result | certificateContextGame adversary budget required stopAfter stopped] *
+      (result.2.2.2.2.1.messageCalls : ENNReal)) ≤ originalCertificateMessageCost adversary := by
+  rw [certificateContextGame, tsum_probOutput_bind_mul]
+  calc
+    _ ≤ ∑' generated, Pr[= generated | (liftM (boundaryRun 0 scheme.keygen ∅) : PMF _)] *
+        expectedBoundaryMessageCalls generated.1.1.2.parameter
+          (simulateQ (expandedAdversaryImpl generated.1.1.2)
+            (retainedGameRestComputation adversary generated.1.1.1)) generated.2 := by
+      apply ENNReal.tsum_le_tsum
+      intro generated
+      apply mul_le_mul' le_rfl
+      rw [tsum_probOutput_bind_mul]
+      simp only [tsum_probOutput_pure_mul]
+      simpa only [initialCertificateMonitor, Nat.cast_zero, zero_add] using
+        expected_certificateCacheProposal_messageCalls_le_original generated.1.1.2 budget required (stopAfter generated.1.1.2)
+          (retainedGameRestComputation adversary generated.1.1.1)
+          ([], generated.2, initialCertificateMonitor generated.1.2.hashCalls stopped, false)
+    _ = _ := by
+      exact expected_probCompLift_of_map_eq (boundaryRun 0 scheme.keygen ∅)
+        ((simulateQ romImpl scheme.keygen).run ∅) (fun result => (result.1.1, result.2))
+        (boundaryRun_forget 0 scheme.keygen ∅) (fun generated =>
+          expectedBoundaryMessageCalls generated.1.2.parameter
+            (simulateQ (expandedAdversaryImpl generated.1.2)
+              (retainedGameRestComputation adversary generated.1.1)) generated.2)
+
+theorem originalCertificateSource_full_le_original_message_add_exception (adversary : Adversary) (q : Nat)
+    (hbudget : q ≤ 2 ^ 127) (hbound : HasHashQueryBound scheme adversary q) :
+    Pr[OriginalFullCertificate | originalCertificateSource adversary] ≤
+      (2 ^ 128 : ENNReal)⁻¹ * originalCertificateMessageCost adversary + (q : ENNReal) * (11 / 2 ^ 144 : ENNReal) +
+      Pr[fun result => CertificateGameExceptional result.2 |
+        certificateContextGame adversary q Finset.univ (fun _ => proposalPrefixStop) false] :=
+  (originalCertificateSource_full_le_message_add_exception adversary q hbudget hbound).trans
+    (add_le_add (add_le_add (mul_le_mul' le_rfl
+      (certificateContextGame_messageCalls_le_original adversary q Finset.univ (fun _ => proposalPrefixStop) false)) le_rfl) le_rfl)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/OriginalCertificateTrace.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/OriginalCertificateTrace.lean
new file mode 100644
index 000000000..a33763318
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/OriginalCertificateTrace.lean
@@ -0,0 +1,105 @@
+import SphincsSecurity.Proof.Fts.BoundaryCertificateCache
+import SphincsSecurity.Proof.Reference.ReferenceForgerySource
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+open FtsProbeSimulation (RetainedRestResult retainedGameRestComputation)
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] scheme retainedGameRestComputation
+
+abbrev CertificateTraceRecord := SecretKey × RetainedRestResult × SigningBoundaryTrace
+abbrev OriginalCertificateTraceResult := OriginalCertificateResult × SigningBoundaryTrace
+
+noncomputable def originalCertificateTraceSource (adversary : Adversary) : ProbComp OriginalCertificateTraceResult := do
+  let generated ← (simulateQ romImpl scheme.keygen).run ∅
+  let result ← boundaryRun generated.1.2.parameter
+    (simulateQ (expandedAdversaryImpl generated.1.2) (retainedGameRestComputation adversary generated.1.1)) generated.2
+  pure ((generated.1.2, result.1.1, result.2), result.1.2)
+
+def OriginalCertificateTraceResult.record (result : OriginalCertificateTraceResult) : CertificateTraceRecord :=
+  (result.1.1, result.1.2.1, result.2)
+
+theorem originalCertificateTraceSource_original (adversary : Adversary) :
+    Prod.fst <$> originalCertificateTraceSource adversary = originalCertificateSource adversary := by
+  simp only [originalCertificateTraceSource, originalCertificateSource, map_bind, map_pure]
+  apply bind_congr
+  intro generated
+  rw [OtsProbeSimulation.simulateQ_unloggedMapped_eq_expanded]
+  have h := congrArg (Functor.map (fun result : RetainedRestResult × QueryCache HashSpec => (generated.1.2, result)))
+    (boundaryRun_forget generated.1.2.parameter
+      (simulateQ (expandedAdversaryImpl generated.1.2) (retainedGameRestComputation adversary generated.1.1)) generated.2)
+  simpa only [Functor.map_map, bind_pure_comp] using h
+
+theorem originalCertificateTraceSource_messageCache_le (adversary : Adversary) (result : OriginalCertificateTraceResult)
+    (hr : result ∈ support (originalCertificateTraceSource adversary)) :
+    hashRowsCache result.2.messageCalls ≤ result.1.2.2 := by
+  simp only [originalCertificateTraceSource, mem_support_bind_iff] at hr
+  obtain ⟨generated, _, recorded, hrecorded, hr⟩ := hr
+  rw [mem_support_pure_iff] at hr
+  subst result
+  exact boundaryRun_messageCache_le _ _ _ recorded hrecorded
+
+def CertificateTraceRecord.full (record : CertificateTraceRecord) : Prop :=
+  SigningTranscript.Valid record.2.1.1.2 ∧
+    ∃ input, TargetCertificateAt record.1 Finset.univ (hashRowsCache record.2.2.messageCalls, record.2.1.1.2) input
+
+theorem originalCertificateTraceSource_full_le (adversary : Adversary) :
+    Pr[fun result => result.record.full | originalCertificateTraceSource adversary] ≤
+      Pr[OriginalFullCertificate | originalCertificateSource adversary] := by
+  rw [← originalCertificateTraceSource_original, probEvent_map]
+  apply _root_.probEvent_mono
+  intro result hr hfull
+  obtain ⟨hvalid, input, hcertificate⟩ := hfull
+  exact ⟨hvalid, input, hcertificate.mono (originalCertificateTraceSource_messageCache_le adversary result hr)⟩
+
+noncomputable def certificateTraceProgram (adversary : Adversary) : OracleComp OracleWorld CertificateTraceRecord := do
+  let generated ← scheme.keygen
+  let result ← boundaryComputation generated.2.parameter
+    (simulateQ (expandedAdversaryImpl generated.2) (retainedGameRestComputation adversary generated.1))
+  pure (generated.2, result.1, result.2)
+
+theorem originalCertificateTraceSource_record (adversary : Adversary) :
+    OriginalCertificateTraceResult.record <$> originalCertificateTraceSource adversary =
+      (simulateQ romImpl (certificateTraceProgram adversary)).run' ∅ := by
+  simp only [originalCertificateTraceSource, certificateTraceProgram, simulateQ_bind, simulateQ_pure,
+    StateT.run'_eq, StateT.run_bind, StateT.run_pure, map_bind, map_pure, OriginalCertificateTraceResult.record]
+  apply bind_congr
+  intro generated
+  have h := congrArg (Functor.map (fun result : RetainedRestResult × SigningBoundaryTrace =>
+    (generated.1.2, result.1, result.2)))
+    (boundaryRun_fst_eq_boundaryComputation generated.1.2.parameter
+      (simulateQ (expandedAdversaryImpl generated.1.2) (retainedGameRestComputation adversary generated.1.1)) generated.2)
+  simpa only [Functor.map_map, bind_pure_comp, StateT.run'_eq] using h
+
+noncomputable def CertificateTraceRecord.verdict (record : CertificateTraceRecord) : Bool :=
+  decide (SigningTranscript.Valid record.2.1.1.2 ∧ ¬SigningTranscript.Contains record.2.1.1.2 record.2.1.1.1) && record.2.1.2
+
+theorem certificateTraceProgram_verdict (adversary : Adversary) :
+    CertificateTraceRecord.verdict <$> certificateTraceProgram adversary = gameCore scheme adversary := by
+  rw [certificateTraceProgram, gameCore_eq]
+  simp only [map_bind, bind_pure_comp]
+  apply bind_congr
+  intro generated
+  have h := congrArg (Functor.map (fun result : RetainedRestResult =>
+    decide (SigningTranscript.Valid result.1.2 ∧ ¬SigningTranscript.Contains result.1.2 result.1.1) && result.2))
+    (boundaryComputation_fst generated.2.parameter
+      (simulateQ (expandedAdversaryImpl generated.2) (retainedGameRestComputation adversary generated.1)))
+  rw [Functor.map_map] at h
+  change (fun result : RetainedRestResult × SigningBoundaryTrace => CertificateTraceRecord.verdict (generated.2, result.1, result.2)) <$> _ = _ at h
+  rw [Functor.map_map, h, OtsProbeSimulation.gameRest_eq_map_retained]
+  unfold retainedGameRestComputation OtsProbeSimulation.retainedGameRestComputation
+  rfl
+
+theorem certificateTraceProgram_hashInputs (adversary : Adversary) :
+    hashInputs (certificateTraceProgram adversary) = hashInputs (boundaryGameCore adversary) := by
+  rw [← ResidualByteFrontend.hashInputs_map CertificateTraceRecord.verdict, certificateTraceProgram_verdict,
+    ← boundaryGameCore_fst, ResidualByteFrontend.hashInputs_map]
+
+theorem certificateTraceProgram_full_le (adversary : Adversary) :
+    Pr[CertificateTraceRecord.full | (simulateQ romImpl (certificateTraceProgram adversary)).run' ∅] ≤
+      Pr[OriginalFullCertificate | originalCertificateSource adversary] := by
+  rw [← originalCertificateTraceSource_record, probEvent_map]
+  exact originalCertificateTraceSource_full_le adversary
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/OriginalMessageAllocation.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/OriginalMessageAllocation.lean
new file mode 100644
index 000000000..d696634b6
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/OriginalMessageAllocation.lean
@@ -0,0 +1,98 @@
+import SphincsSecurity.Proof.Fts.OriginalCertificateBound
+import SphincsSecurity.Proof.Reference.ReferenceQueryAllocation
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (retainedGameRestComputation)
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] scheme treeRoot gameAfterSecrets expectedBoundaryMessageCalls
+  canonicalGraphGameInputs canonicalEncodingInputs canonicalGraphInputs retainedGameRestComputation
+
+private theorem romRun_sampling_bind {Source Result : Type} (source : ProbComp Source)
+    (next : Source → OracleComp OracleWorld Result) (cache : QueryCache HashSpec) :
+    (simulateQ romImpl ((liftM source : OracleComp OracleWorld Source) >>= next)).run cache =
+      source >>= fun value => (simulateQ romImpl (next value)).run cache := by
+  rw [simulateQ_bind, StateT.run_bind,
+    show simulateQ romImpl (liftM source : OracleComp OracleWorld Source) =
+      simulateQ (unifFwdImpl HashSpec) source from QueryImpl.simulateQ_add_liftM_left _ _ source,
+    unifFwdImpl.simulateQ_run, bind_map_left]
+
+theorem expected_boundaryComputation_messageCalls {Result : Type} (parameter : PublicParameter)
+    (computation : OracleComp OracleWorld Result) (cache : QueryCache HashSpec) :
+    (∑' result, Pr[= result | (simulateQ romImpl (boundaryComputation parameter computation)).run' cache] *
+      (result.2.messageCalls.length : ENNReal)) = expectedBoundaryMessageCalls parameter computation cache := by
+  have h := congrArg (fun law : ProbComp (Result × SigningBoundaryTrace) =>
+    ∑' result, Pr[= result | law] * (result.2.messageCalls.length : ENNReal))
+    (boundaryRun_fst_eq_boundaryComputation parameter computation cache)
+  rw [tsum_probOutput_map_mul] at h
+  rw [expectedBoundaryMessageCalls]
+  exact h.symm
+
+theorem expectedBoundaryMessageCalls_retained_eq_gameRest (adversary : Adversary) (key : SecretKey)
+    (publicKey : PublicKey) (cache : QueryCache HashSpec) :
+    expectedBoundaryMessageCalls key.parameter
+      (simulateQ (expandedAdversaryImpl key) (retainedGameRestComputation adversary publicKey)) cache =
+      expectedBoundaryMessageCalls key.parameter (gameRest scheme adversary publicKey key) cache := by
+  rw [expectedBoundaryMessageCalls_eq_queryCharge, expectedBoundaryMessageCalls_eq_queryCharge]
+  have hretained : retainedGameRestComputation adversary publicKey =
+      OtsProbeSimulation.retainedGameRestComputation adversary publicKey := by
+    unfold OtsProbeSimulation.retainedGameRestComputation retainedGameRestComputation
+    rfl
+  rw [hretained, OtsProbeSimulation.expectedQueryCharge_retained_eq_gameRest]
+
+theorem originalCertificateMessageCost_le_boundaryGameCore (adversary : Adversary) :
+    originalCertificateMessageCost adversary ≤
+      ∑' result, Pr[= result | (simulateQ romImpl (boundaryGameCore adversary)).run' ∅] *
+        (result.2.messageCalls.length : ENNReal) := by
+  rw [originalCertificateMessageCost, show scheme.keygen = keygen by rw [scheme]]
+  conv_lhs => rw [keygen, romRun_sampling_bind, tsum_probOutput_bind_mul]
+  conv_rhs => rw [boundaryGameCore, simulateQ_romImpl_liftM_bind_run', tsum_probOutput_bind_mul]
+  apply ENNReal.tsum_le_tsum
+  intro parameter
+  apply mul_le_mul' le_rfl
+  conv_lhs => rw [romRun_sampling_bind, tsum_probOutput_bind_mul]
+  conv_rhs => rw [simulateQ_romImpl_liftM_bind_run', tsum_probOutput_bind_mul]
+  apply ENNReal.tsum_le_tsum
+  intro otsSecret
+  apply mul_le_mul' le_rfl
+  conv_lhs => rw [romRun_sampling_bind, tsum_probOutput_bind_mul]
+  conv_rhs => rw [simulateQ_romImpl_liftM_bind_run', tsum_probOutput_bind_mul]
+  apply ENNReal.tsum_le_tsum
+  intro ftsSecret
+  apply mul_le_mul' le_rfl
+  conv_lhs => rw [simulateQ_bind, StateT.run_bind, tsum_probOutput_bind_mul]
+  simp only [simulateQ_pure, StateT.run_pure, tsum_probOutput_pure_mul,
+    expectedBoundaryMessageCalls_retained_eq_gameRest]
+  rw [expected_boundaryComputation_messageCalls, gameAfterSecrets, expectedBoundaryMessageCalls_bind]
+  exact le_add_self
+
+theorem boundaryGameCore_messageCalls_eq_referenceRecorded (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (∑' result, Pr[= result | (simulateQ romImpl (boundaryGameCore adversary)).run' ∅] *
+      (result.2.messageCalls.length : ENNReal)) =
+      ∑' result, Pr[= result | referenceRecordedGame (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] * (result.messageCalls : ENNReal) := by
+  have h := evalDist_boundaryGameCore_referenceFamily (canonicalGraphGameInputs adversary)
+    (canonicalEncodingInputs_subset_gameInputs adversary) (canonicalGraphInputs_subset_gameInputs adversary)
+    dummy adversary (hashInputs_subset_canonicalGraphGameInputs adversary)
+  have hp := (evalDist_ext_iff
+    (mx := (simulateQ romImpl (boundaryGameCore adversary)).run' ∅)
+    (mx' := Prod.snd <$> referenceFamilyGame (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary)).mp h
+  calc
+    _ = ∑' result, Pr[= result | Prod.snd <$> referenceFamilyGame (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] *
+          (result.2.messageCalls.length : ENNReal) := tsum_congr fun result => congrArg (· * _) (hp result)
+    _ = _ := by
+      rw [tsum_probOutput_map_mul,
+        ← referenceRecordedGame_erased (canonicalGraphGameInputs adversary)
+          (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary, tsum_probOutput_map_mul]
+      rfl
+
+theorem originalCertificateMessageCost_le_referenceRecorded (dummy : OtsReferenceWords) (adversary : Adversary) :
+    originalCertificateMessageCost adversary ≤
+      ∑' result, Pr[= result | referenceRecordedGame (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] * (result.messageCalls : ENNReal) :=
+  (originalCertificateMessageCost_le_boundaryGameCore adversary).trans_eq
+    (boundaryGameCore_messageCalls_eq_referenceRecorded dummy adversary)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/OriginalProposalBudget.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/OriginalProposalBudget.lean
new file mode 100644
index 000000000..5faace6ac
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/OriginalProposalBudget.lean
@@ -0,0 +1,88 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.BankedProposalStep
+import SphincsSecurity.Proof.Reference.DirectQueryBudget
+import SphincsSecurity.Proof.Reference.SigningBoundaryHashCost
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem probCompLift_support {α : Type} (computation : ProbComp α) :
+    (liftM computation : PMF α).support = support computation := by
+  ext value
+  rw [PMF.mem_support_iff, ← PMF.probOutput_eq_apply, mem_support_iff]
+  rfl
+
+theorem originalProposalRecord_boundary (key : SecretKey)
+    (input : (OracleWorld + SigningSpec).Domain) (cache : QueryCache HashSpec) :
+    (originalProposalRecord key input cache).map (fun record => ((record.output, record.trace), record.cache)) =
+      (liftM (boundaryRun key.parameter (expandedAdversaryImpl key input) cache) : PMF _) := by
+  cases input with
+  | inl world =>
+      simp only [originalProposalRecord, PMF.map_comp, expandedAdversaryImpl]
+      rw [boundaryRun_query]
+      exact (liftM_map (m := ProbComp) (n := PMF) _ _).symm
+  | inr message =>
+      rw [originalProposalRecord, PMF.map_comp]
+      calc
+        _ = ((completedSigningRecord (signingBoundaryTrace key.parameter) key message cache).map Prod.fst).map
+            signingRecordResponse := (PMF.map_comp _ _ _).symm
+        _ = _ := by
+          rw [completedSigningRecord_forget, ← PMF.monad_map_eq_map,
+            ← liftM_map (m := ProbComp) (n := PMF), tracedSigningRun_signature]
+          rfl
+
+theorem originalProposalRecord_boundary_support (key : SecretKey)
+    (input : (OracleWorld + SigningSpec).Domain) (cache : QueryCache HashSpec)
+    (record : ProposalExecutionRecord input) (hr : record ∈ (originalProposalRecord key input cache).support) :
+    ((record.output, record.trace), record.cache) ∈
+      support (boundaryRun key.parameter (expandedAdversaryImpl key input) cache) := by
+  have hm := (PMF.mem_support_map_iff
+    (fun record : ProposalExecutionRecord input => ((record.output, record.trace), record.cache))
+    (originalProposalRecord key input cache) _).mpr ⟨record, hr, rfl⟩
+  rwa [originalProposalRecord_boundary, probCompLift_support] at hm
+
+theorem originalProposalRecord_query_bound {α : Type} (key : SecretKey)
+    (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α)
+    (q : Nat)
+    (hbound : (simulateQ (expandedAdversaryImpl key) (OracleSpec.query input >>= next)).IsQueryBoundP (· matches .inr _) q)
+    (cache : QueryCache HashSpec) (record : ProposalExecutionRecord input)
+    (hr : record ∈ (originalProposalRecord key input cache).support) :
+    record.trace.hashCalls ≤ q ∧
+      (simulateQ (expandedAdversaryImpl key) (next record.output)).IsQueryBoundP (· matches .inr _)
+        (q - record.trace.hashCalls) := by
+  rw [simulateQ_bind, simulateQ_spec_query] at hbound
+  exact boundaryRun_bind_query_bound key.parameter (expandedAdversaryImpl key input)
+    (fun output => simulateQ (expandedAdversaryImpl key) (next output)) q hbound cache _
+    (originalProposalRecord_boundary_support key input cache record hr)
+
+theorem originalProposalRecord_sign_hashCalls (key : SecretKey) (message : Message)
+    (cache : QueryCache HashSpec) (record : ProposalExecutionRecord (.inr message))
+    (hr : record ∈ (originalProposalRecord key (.inr message) cache).support) :
+    28504 ≤ record.trace.hashCalls :=
+  boundaryHashAtLeast_sign key.parameter key message cache _
+    (originalProposalRecord_boundary_support key (.inr message) cache record hr)
+
+theorem targetCreationMultiplier_le_record_hashCalls (key : SecretKey)
+    (input : (OracleWorld + SigningSpec).Domain) (cache : QueryCache HashSpec)
+    (record : ProposalExecutionRecord input) (hr : record ∈ (originalProposalRecord key input cache).support) :
+    targetCreationMultiplier key cache input ≤ record.trace.hashCalls := by
+  cases input with
+  | inl world =>
+      rw [originalProposalRecord_world_hashCalls key world cache record hr, targetCreationMultiplier]
+      cases world with
+      | inl sample => exact le_refl _
+      | inr input =>
+          simp only [freshWorldTargetHashCost, signingExecutionHashCost]
+          split_ifs <;> norm_num
+  | inr message =>
+      have hmass := mul_le_mul' (le_refl (((2 ^ ftsTreeHeight : Nat) : ENNReal)))
+        (freshDigestSelectionProbability_le_one key message cache)
+      calc
+        _ ≤ ((2 ^ ftsTreeHeight : Nat) : ENNReal) := by simpa only [targetCreationMultiplier, mul_one] using hmass
+        _ ≤ (28504 : Nat) := by norm_num [ftsTreeHeight]
+        _ ≤ record.trace.hashCalls := Nat.cast_le.mpr (originalProposalRecord_sign_hashCalls key message cache record hr)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/OriginalProposalExecution.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/OriginalProposalExecution.lean
new file mode 100644
index 000000000..4c055b28f
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/OriginalProposalExecution.lean
@@ -0,0 +1,195 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.ProposalQueryProjection
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+
+private theorem probCompLift_map {α β : Type} (comp : ProbComp α) (f : α → β) :
+    (liftM comp : PMF α).map f = (liftM (f <$> comp) : PMF β) :=
+  (liftM_map (m := ProbComp) (n := PMF) _ _).symm
+
+private theorem tracedSigningRun_output {ω : Type} [Monoid ω]
+    (trace : (input : OracleWorld.Domain) → OracleWorld.Range input → ω)
+    (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) :
+    (fun result : TracedSigningRecord ω => (result.1.1.1, result.2)) <$>
+      tracedSigningRun trace key message cache = (simulateQ romImpl (sign key message)).run cache := by
+  calc
+    _ = (fun result => (result.1.1, result.2)) <$>
+        ((fun result : TracedSigningRecord ω => (result.1.1, result.2)) <$>
+          tracedSigningRun trace key message cache) := by simp only [Functor.map_map]
+    _ = _ := by rw [tracedSigningRun_forget, simulateQ_signWithView_fst_run]
+
+private theorem completedSigningRecord_output {ω : Type} [Monoid ω]
+    (trace : (input : OracleWorld.Domain) → OracleWorld.Range input → ω)
+    (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) :
+    (completedSigningRecord trace key message cache).map (fun result => (result.1.1.1.1, result.1.2)) =
+      (liftM ((simulateQ romImpl (sign key message)).run cache) : PMF _) := by
+  calc
+    _ = ((completedSigningRecord trace key message cache).map Prod.fst).map
+        (fun result : TracedSigningRecord ω => (result.1.1.1, result.2)) := (PMF.map_comp _ _ _).symm
+    _ = _ := by rw [completedSigningRecord_forget, probCompLift_map, tracedSigningRun_output]
+
+structure ProposalExecutionRecord (input : (OracleWorld + SigningSpec).Domain) where
+  output : (OracleWorld + SigningSpec).Range input
+  cache : QueryCache HashSpec
+  trace : SigningBoundaryTrace
+  selectedView : Option FewTimeView
+  index : Index
+
+noncomputable def originalProposalRecord (key : SecretKey) :
+    (input : (OracleWorld + SigningSpec).Domain) → QueryCache HashSpec → PMF (ProposalExecutionRecord input)
+  | .inl world, cache =>
+      (liftM ((romImpl world).run cache) : PMF _).map fun result =>
+        ⟨result.1, result.2, signingBoundaryTrace key.parameter world result.1, none, 0⟩
+  | .inr message, cache =>
+      (completedSigningRecord (signingBoundaryTrace key.parameter) key message cache).map fun result =>
+        ⟨result.1.1.1.1, result.1.2, result.1.1.2, result.1.1.1.2, result.2⟩
+
+noncomputable def originalAdversaryPMFImpl (key : SecretKey) :
+    QueryImpl (OracleWorld + SigningSpec) (StateT (QueryCache HashSpec) PMF) :=
+  pmfSumImpl romImpl (fun message => simulateQ romImpl (sign key message))
+
+theorem originalAdversaryImpl_split (key : SecretKey) :
+    (romImpl + (fun message => simulateQ romImpl (sign key message))) = unloggedMappedAdversaryImpl key := by
+  funext input
+  cases input with
+  | inl world => rfl
+  | inr message =>
+      change simulateQ romImpl (sign key message) = simulateQ romImpl (scheme.sign key message)
+      have hsign : scheme.sign = sign := rfl
+      rw [hsign]
+
+theorem simulateQ_originalAdversaryPMFImpl {α : Type} (key : SecretKey)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (cache : QueryCache HashSpec) :
+    (simulateQ (originalAdversaryPMFImpl key) computation).run cache =
+      (liftM ((simulateQ (unloggedMappedAdversaryImpl key) computation).run cache) : PMF _) := by
+  rw [originalAdversaryPMFImpl, pmfSumImpl_eq_lift_add, simulateQ_liftProbCompImpl_run,
+    originalAdversaryImpl_split]
+
+theorem originalProposalRecord_project (key : SecretKey)
+    (input : (OracleWorld + SigningSpec).Domain) (cache : QueryCache HashSpec) :
+    (originalProposalRecord key input cache).map (fun result => (result.output, result.cache)) =
+      (originalAdversaryPMFImpl key input).run cache := by
+  cases input with
+  | inl world =>
+      rw [originalAdversaryPMFImpl, pmfSumImpl_inl, originalProposalRecord, PMF.map_comp]
+      exact PMF.map_id _
+  | inr message =>
+      rw [originalAdversaryPMFImpl, pmfSumImpl_inr, originalProposalRecord, PMF.map_comp]
+      exact completedSigningRecord_output (signingBoundaryTrace key.parameter) key message cache
+
+theorem originalProposalRecord_index (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) :
+    (originalProposalRecord key (.inr message) cache).map (fun result => result.index) =
+      (completedSigningRecord (signingBoundaryTrace key.parameter) key message cache).map Prod.snd := by
+  rw [originalProposalRecord, PMF.map_comp]
+  rfl
+
+theorem originalProposalRecord_cap (key : SecretKey) (message : Message) (cache : QueryCache HashSpec)
+    (spent : Nat) (hbound : ProposalCacheBound key cache spent) (index : Index) :
+    targetProposalAcceptance *
+      ((originalProposalRecord key (.inr message) cache).map (fun result => result.index)) index ≤
+      PMF.uniformOfFintype Index index := by
+  rw [originalProposalRecord_index]
+  exact completedSigningRecord_acceptance_cap (signingBoundaryTrace key.parameter) key message cache spent hbound index
+
+noncomputable def originalProposalActive {μ : Type} (key : SecretKey)
+    (spent : QueryCache HashSpec × μ → Nat) (enabled : Message → QueryCache HashSpec × μ → Bool) :
+    (OracleWorld + SigningSpec).Domain → QueryCache HashSpec × μ → Bool
+  | .inl _, _ => false
+  | .inr message, state => enabled message state && decide (ProposalCacheBound key state.1 (spent state))
+
+noncomputable def originalRejectedProposal {μ : Type} (key : SecretKey)
+    (spent : QueryCache HashSpec × μ → Nat) :
+    (OracleWorld + SigningSpec).Domain → QueryCache HashSpec × μ → PMF Index
+  | .inl _, _ => PMF.uniformOfFintype Index
+  | .inr message, state =>
+      if hbound : ProposalCacheBound key state.1 (spent state) then
+        proposalResidualLaw (PMF.uniformOfFintype Index)
+          ((originalProposalRecord key (.inr message) state.1).map (fun result => result.index))
+          targetProposalAcceptance targetProposalAcceptance_lt_one
+          (originalProposalRecord_cap key message state.1 (spent state) hbound)
+      else PMF.uniformOfFintype Index
+
+def originalProposalAdvance {μ : Type}
+    (update : (input : (OracleWorld + SigningSpec).Domain) → QueryCache HashSpec × μ →
+      Nat → ProposalExecutionRecord input → μ)
+    (input : (OracleWorld + SigningSpec).Domain) (state : QueryCache HashSpec × μ)
+    (length : Nat) (record : ProposalExecutionRecord input) : QueryCache HashSpec × μ :=
+  (record.cache, update input state length record)
+
+noncomputable def originalProposalImpl {μ : Type} (key : SecretKey)
+    (spent : QueryCache HashSpec × μ → Nat) (enabled : Message → QueryCache HashSpec × μ → Bool)
+    (update : (input : (OracleWorld + SigningSpec).Domain) → QueryCache HashSpec × μ →
+      Nat → ProposalExecutionRecord input → μ) :
+    QueryImpl (OracleWorld + SigningSpec) (StateT (List Index × (QueryCache HashSpec × μ)) PMF) :=
+  proposalRecordImpl (fun input state => originalProposalRecord key input state.1)
+    (fun _ record => record.output) (originalProposalAdvance update) (fun _ record => record.index)
+    (originalRejectedProposal key spent) (originalProposalActive key spent enabled)
+    targetProposalAcceptance targetProposalAcceptance_ne_zero targetProposalAcceptance_lt_one.le
+
+noncomputable def originalLengthImpl {μ : Type} (key : SecretKey)
+    (spent : QueryCache HashSpec × μ → Nat) (enabled : Message → QueryCache HashSpec × μ → Bool)
+    (update : (input : (OracleWorld + SigningSpec).Domain) → QueryCache HashSpec × μ →
+      Nat → ProposalExecutionRecord input → μ) :
+    QueryImpl (OracleWorld + SigningSpec) (StateT (QueryCache HashSpec × μ) PMF) :=
+  lengthRecordImpl (fun input state => originalProposalRecord key input state.1)
+    (fun _ record => record.output) (originalProposalAdvance update) (originalProposalActive key spent enabled)
+    targetProposalAcceptance targetProposalAcceptance_ne_zero targetProposalAcceptance_lt_one.le
+
+theorem simulateQ_originalProposalImpl_length {μ α : Type} (key : SecretKey)
+    (spent : QueryCache HashSpec × μ → Nat) (enabled : Message → QueryCache HashSpec × μ → Bool)
+    (update : (input : (OracleWorld + SigningSpec).Domain) → QueryCache HashSpec × μ →
+      Nat → ProposalExecutionRecord input → μ)
+    (computation : OracleComp (OracleWorld + SigningSpec) α)
+    (state : List Index × (QueryCache HashSpec × μ)) :
+    Prod.map id Prod.snd <$> (simulateQ (originalProposalImpl key spent enabled update) computation).run state =
+      (simulateQ (originalLengthImpl key spent enabled update) computation).run state.2 :=
+  simulateQ_proposalRecordImpl_project _ _ _ _ _ _ _ _ _ computation state
+
+theorem simulateQ_originalLengthImpl_forget {μ α : Type} (key : SecretKey)
+    (spent : QueryCache HashSpec × μ → Nat) (enabled : Message → QueryCache HashSpec × μ → Bool)
+    (update : (input : (OracleWorld + SigningSpec).Domain) → QueryCache HashSpec × μ →
+      Nat → ProposalExecutionRecord input → μ)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (state : QueryCache HashSpec × μ) :
+    Prod.map id Prod.fst <$> (simulateQ (originalLengthImpl key spent enabled update) computation).run state =
+      (simulateQ (originalAdversaryPMFImpl key) computation).run state.1 := by
+  apply simulateQ_lengthRecordImpl_project
+    (fun input state => originalProposalRecord key input state.1)
+    (fun _ record => record.output) (originalProposalAdvance update) (originalProposalActive key spent enabled)
+    targetProposalAcceptance targetProposalAcceptance_ne_zero targetProposalAcceptance_lt_one.le
+    (originalAdversaryPMFImpl key) Prod.fst (fun _ _ record => record.cache)
+  · intros
+    rfl
+  · intro input state
+    exact originalProposalRecord_project key input state.1
+
+theorem simulateQ_originalProposalImpl_forget {μ α : Type} (key : SecretKey)
+    (spent : QueryCache HashSpec × μ → Nat) (enabled : Message → QueryCache HashSpec × μ → Bool)
+    (update : (input : (OracleWorld + SigningSpec).Domain) → QueryCache HashSpec × μ →
+      Nat → ProposalExecutionRecord input → μ)
+    (computation : OracleComp (OracleWorld + SigningSpec) α)
+    (state : List Index × (QueryCache HashSpec × μ)) :
+    (fun result => (result.1, result.2.2.1)) <$>
+      (simulateQ (originalProposalImpl key spent enabled update) computation).run state =
+      (simulateQ (originalAdversaryPMFImpl key) computation).run state.2.1 := by
+  calc
+    _ = Prod.map id Prod.fst <$>
+        (Prod.map id Prod.snd <$>
+          (simulateQ (originalProposalImpl key spent enabled update) computation).run state) := by
+      simp only [Functor.map_map]
+      rfl
+    _ = _ := by rw [simulateQ_originalProposalImpl_length, simulateQ_originalLengthImpl_forget]
+
+theorem simulateQ_originalProposalImpl_original {μ α : Type} (key : SecretKey)
+    (spent : QueryCache HashSpec × μ → Nat) (enabled : Message → QueryCache HashSpec × μ → Bool)
+    (update : (input : (OracleWorld + SigningSpec).Domain) → QueryCache HashSpec × μ →
+      Nat → ProposalExecutionRecord input → μ)
+    (computation : OracleComp (OracleWorld + SigningSpec) α)
+    (state : List Index × (QueryCache HashSpec × μ)) :
+    (fun result => (result.1, result.2.2.1)) <$>
+      (simulateQ (originalProposalImpl key spent enabled update) computation).run state =
+      (liftM ((simulateQ (unloggedMappedAdversaryImpl key) computation).run state.2.1) : PMF _) := by
+  rw [simulateQ_originalProposalImpl_forget, simulateQ_originalAdversaryPMFImpl]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/OriginalProposalPrefixBound.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/OriginalProposalPrefixBound.lean
new file mode 100644
index 000000000..7b9691f6a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/OriginalProposalPrefixBound.lean
@@ -0,0 +1,155 @@
+import SphincsSecurity.Proof.Fts.OriginalCacheExceptionBound
+import SphincsSecurity.Proof.Fts.ProposalPrefixExponential
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] scheme certificateLengthImpl certificateProposalImpl certificateCacheProposalImpl proposalPrefixWeight
+
+private theorem certificateMonitorUpdate_log_cap (key : SecretKey) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : CertificateStopRule) (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState)
+    (length : Nat) (record : ProposalExecutionRecord input) (hcap : state.2.log.length ≤ signatureLimit) :
+    (certificateMonitorUpdate key budget required stopAfter input state length record).log.length ≤ signatureLimit := by
+  by_cases hactive : CertificateMonitorActive key budget input state
+  · rw [certificateMonitorUpdate, if_pos hactive]
+    have hvalid := hactive.2.2.1
+    cases input <;>
+      simp only [proposalRecordLogState, signingLogFragment, List.append_nil, List.length_append, List.length_singleton,
+        ValidSigningStep] at hvalid ⊢ <;> omega
+  · simpa only [certificateMonitorUpdate, if_neg hactive] using hcap
+
+private theorem certificateMonitorUpdate_world_prefixWeight (key : SecretKey) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : CertificateStopRule) (input : OracleWorld.Domain) (state : CertificateMonitorState)
+    (record : ProposalExecutionRecord (.inl input)) :
+    proposalPrefixWeight (certificateMonitorUpdate key budget required stopAfter (.inl input) state 0 record).proposals
+      (certificateMonitorUpdate key budget required stopAfter (.inl input) state 0 record).log.length =
+        proposalPrefixWeight state.2.proposals state.2.log.length := by
+  rw [certificateMonitorUpdate]
+  split <;> simp only [proposalRecordLogState, signingLogFragment, List.append_nil, Nat.add_zero]
+
+private theorem certificateMonitorUpdate_sign_prefixWeight (key : SecretKey) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : CertificateStopRule) (message : Message) (state : CertificateMonitorState)
+    (length : Nat) (record : ProposalExecutionRecord (.inr message))
+    (hactive : CertificateMonitorActive key budget (.inr message) state) :
+    proposalPrefixWeight (certificateMonitorUpdate key budget required stopAfter (.inr message) state length record).proposals
+      (certificateMonitorUpdate key budget required stopAfter (.inr message) state length record).log.length =
+        proposalPrefixWeight (state.2.proposals + length) (state.2.log.length + 1) := by
+  simp only [certificateMonitorUpdate, if_pos hactive, proposalRecordLogState, signingLogFragment,
+    List.length_append, List.length_singleton]
+
+theorem expected_certificateLengthImpl_prefixWeight (key : SecretKey) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : CertificateStopRule) (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState) :
+    (∑' result, Pr[= result | (certificateLengthImpl key budget required stopAfter input).run state] *
+      proposalPrefixWeight result.2.2.proposals result.2.2.log.length) = proposalPrefixWeight state.2.proposals state.2.log.length := by
+  cases input with
+  | inl input =>
+      rw [certificateLengthImpl_world_run, ← PMF.monad_map_eq_map, tsum_probOutput_map_mul]
+      simp only [originalProposalAdvance, certificateMonitorUpdate_world_prefixWeight, ENNReal.tsum_mul_right,
+        tsum_probOutput_of_liftM_PMF, one_mul]
+  | inr message =>
+      by_cases hactive : CertificateMonitorActive key budget (.inr message) state
+      · rw [certificateLengthImpl_sign_run, if_pos hactive, ← PMF.monad_map_eq_map, tsum_probOutput_map_mul]
+        simp only [originalProposalAdvance, certificateMonitorUpdate_sign_prefixWeight key budget required stopAfter message state _ _ hactive]
+        have h := congrArg (fun law : PMF Nat => ∑' length, Pr[= length | law] *
+          proposalPrefixWeight (state.2.proposals + length) (state.2.log.length + 1))
+          (recordLengthBridge_length (originalProposalRecord key (.inr message) state.1)
+            targetProposalAcceptance targetProposalAcceptance_ne_zero targetProposalAcceptance_lt_one.le)
+        rw [← PMF.monad_map_eq_map, tsum_probOutput_map_mul] at h
+        simp only [PMF.probOutput_eq_apply] at h
+        simpa only [PMF.probOutput_eq_apply] using h.trans
+          (expected_proposalPrefixWeight state.2.proposals state.2.log.length hactive.2.2.1)
+      · rw [certificateLengthImpl_inactive_run key budget required stopAfter (.inr message) state hactive,
+          ← PMF.monad_map_eq_map, tsum_probOutput_map_mul]
+        simp only [ENNReal.tsum_mul_right, tsum_probOutput_of_liftM_PMF, one_mul]
+
+theorem expected_certificateLength_prefixWeight {Result : Type} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) (state : CertificateMonitorState) :
+    (∑' result, Pr[= result | (simulateQ (certificateLengthImpl key budget required stopAfter) computation).run state] *
+      proposalPrefixWeight result.2.2.proposals result.2.2.log.length) = proposalPrefixWeight state.2.proposals state.2.log.length := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [simulateQ_pure, StateT.run_pure, tsum_probOutput_pure_mul]
+  | query_bind input next ih =>
+      rw [simulateQ_bind, simulateQ_spec_query, StateT.run_bind, tsum_probOutput_bind_mul]
+      simp only [ih]
+      exact expected_certificateLengthImpl_prefixWeight key budget required stopAfter input state
+
+theorem certificateLength_log_cap {Result : Type} (key : SecretKey) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : CertificateStopRule) (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : CertificateMonitorState) (hcap : state.2.log.length ≤ signatureLimit) (result : Result × CertificateMonitorState)
+    (hr : result ∈ ((simulateQ (certificateLengthImpl key budget required stopAfter) computation).run state).support) :
+    result.2.2.log.length ≤ signatureLimit := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      rw [simulateQ_pure, StateT.run_pure, PMF.monad_pure_eq_pure, PMF.mem_support_pure_iff] at hr
+      subst result
+      exact hcap
+  | query_bind input next ih =>
+      rw [simulateQ_bind, simulateQ_spec_query, StateT.run_bind, PMF.monad_bind_eq_bind, PMF.mem_support_bind_iff] at hr
+      obtain ⟨middle, hm, hr⟩ := hr
+      obtain ⟨length, record, _, rfl⟩ := certificateLengthImpl_support key budget required stopAfter input state middle hm
+      exact ih record.output _ (certificateMonitorUpdate_log_cap key budget required stopAfter input state length record hcap) result hr
+
+theorem certificateLength_prefix_le {Result : Type} (key : SecretKey) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : CertificateStopRule) (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : CertificateMonitorState) (hcap : state.2.log.length ≤ signatureLimit) :
+    Pr[fun result => ProposalPrefixExceptional result.2.2.proposals result.2.2.log.length |
+      (simulateQ (certificateLengthImpl key budget required stopAfter) computation).run state] ≤
+      proposalPrefixWeight state.2.proposals state.2.log.length := by
+  rw [← expected_certificateLength_prefixWeight key budget required stopAfter computation state, probEvent_eq_tsum_ite]
+  apply ENNReal.tsum_le_tsum
+  intro result
+  by_cases hr : result ∈ ((simulateQ (certificateLengthImpl key budget required stopAfter) computation).run state).support
+  · by_cases hb : ProposalPrefixExceptional result.2.2.proposals result.2.2.log.length
+    · rw [if_pos hb]
+      simpa only [mul_one] using mul_le_mul' (le_refl
+        (Pr[= result | (simulateQ (certificateLengthImpl key budget required stopAfter) computation).run state]))
+        (proposalPrefixWeight_bad _ _ (certificateLength_log_cap key budget required stopAfter computation state hcap result hr) hb)
+    · rw [if_neg hb]
+      exact bot_le
+  · have hz : (simulateQ (certificateLengthImpl key budget required stopAfter) computation).run state result = 0 := by
+      simpa only [PMF.mem_support_iff, not_not] using hr
+    simp only [PMF.probOutput_eq_apply, hz, ite_self, zero_mul, le_refl]
+
+theorem certificateCacheProposal_prefix_le {Result : Type} (key : SecretKey) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : CertificateStopRule) (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : List Index × CertificateCacheMonitorState) (hcap : state.2.2.1.log.length ≤ signatureLimit) :
+    Pr[fun result => ProposalPrefixExceptional result.2.2.2.1.proposals result.2.2.2.1.log.length |
+      (simulateQ (certificateCacheProposalImpl key budget required stopAfter) computation).run state] ≤
+      proposalPrefixWeight state.2.2.1.proposals state.2.2.1.log.length := by
+  have h := certificateLength_prefix_le key budget required stopAfter computation (certificateCacheMonitorProject state.2) hcap
+  rw [← simulateQ_certificateProposalImpl_length key budget required stopAfter computation
+    (state.1, certificateCacheMonitorProject state.2), probEvent_map] at h
+  rw [← simulateQ_certificateCacheProposalImpl_project key budget required stopAfter computation state, probEvent_map] at h
+  exact h
+
+theorem certificateContextGame_prefix_le (adversary : Adversary) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : SecretKey → CertificateStopRule) (stopped : Bool) :
+    Pr[fun result => ProposalPrefixExceptional result.2.2.2.2.1.proposals result.2.2.2.2.1.log.length |
+      certificateContextGame adversary budget required stopAfter stopped] ≤ (2 ^ 700 : ENNReal)⁻¹ := by
+  rw [certificateContextGame, probEvent_bind_eq_tsum]
+  calc
+    _ ≤ ∑' generated, Pr[= generated | (liftM (boundaryRun 0 scheme.keygen ∅) : PMF _)] * proposalPrefixWeight 0 0 := by
+      apply ENNReal.tsum_le_tsum
+      intro generated
+      apply mul_le_mul' le_rfl
+      have h := certificateCacheProposal_prefix_le generated.1.1.2 budget required (stopAfter generated.1.1.2)
+        (FtsProbeSimulation.retainedGameRestComputation adversary generated.1.1.1)
+        ([], generated.2, initialCertificateMonitor generated.1.2.hashCalls stopped, false) (Nat.zero_le _)
+      simpa only [bind_pure_comp, probEvent_map, initialCertificateMonitor, List.length_nil, Function.comp_def] using h
+    _ = proposalPrefixWeight 0 0 := by rw [ENNReal.tsum_mul_right, tsum_probOutput_of_liftM_PMF, one_mul]
+    _ ≤ _ := proposalPrefixWeight_initial_le
+
+theorem original_primitive_add_full_certificate_small_budget (dummy : OtsReferenceWords)
+    (adversary : Adversary) (q : Nat) (hbound : HasHashQueryBound scheme adversary q)
+    (hsmall : q ≤ 3 * 2 ^ 114) :
+    Pr[GraphPrimitiveEvent dummy | referenceGraphContextGame contactObserver (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] +
+      Pr[OriginalFullCertificate | originalCertificateSource adversary] ≤
+      (7 / 4 : ENNReal) * ((q : ENNReal) / 2 ^ 128) + (q : ENNReal) * (11 / 2 ^ 144 : ENNReal) +
+      (2 ^ 700 : ENNReal)⁻¹ :=
+  (original_primitive_add_full_certificate_le_small_budget_add_prefix dummy adversary q hbound hsmall).trans
+    (add_le_add le_rfl (certificateContextGame_prefix_le adversary q Finset.univ (fun _ => proposalPrefixStop) false))
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/OriginalTerminalProposal.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/OriginalTerminalProposal.lean
new file mode 100644
index 000000000..9c71ded91
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/OriginalTerminalProposal.lean
@@ -0,0 +1,71 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.OriginalProposalExecution
+import SphincsSecurity.Proof.Fts.TerminalProposalWord
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem originalProposalImpl_complete {μ : Type} (key : SecretKey)
+    (spent : QueryCache HashSpec × μ → Nat) (enabled : Message → QueryCache HashSpec × μ → Bool)
+    (update : (input : (OracleWorld + SigningSpec).Domain) → QueryCache HashSpec × μ →
+      Nat → ProposalExecutionRecord input → μ)
+    (total : Nat) (input : (OracleWorld + SigningSpec).Domain) (state : List Index × (QueryCache HashSpec × μ)) :
+    ((originalProposalImpl key spent enabled update input).run state).bind
+        (fun result => completeProposalWord (PMF.uniformOfFintype Index) total result.2.1) =
+      completeProposalWord (PMF.uniformOfFintype Index) total state.1 := by
+  simp only [originalProposalImpl, proposalRecordImpl, StateT.run_mk]
+  by_cases hactive : originalProposalActive key spent enabled input state.2 = true
+  · rw [if_pos hactive, PMF.bind_map]
+    cases input with
+    | inl world => simp only [originalProposalActive, Bool.false_eq_true] at hactive
+    | inr message =>
+        have hcache : ProposalCacheBound key state.2.1 (spent state.2) := by
+          by_contra hcache
+          simp [originalProposalActive, hcache] at hactive
+        rw [originalRejectedProposal, dif_pos hcache]
+        simpa only [cappedRecordProposalBridge, List.append_assoc, Function.comp_def] using
+          complete_cappedRecordProposalBridge_prefix (PMF.uniformOfFintype Index)
+            (originalProposalRecord key (.inr message) state.2.1) (fun record => record.index)
+            targetProposalAcceptance targetProposalAcceptance_ne_zero targetProposalAcceptance_lt_one
+            (originalProposalRecord_cap key message state.2.1 (spent state.2) hcache) total state.1
+  · rw [if_neg hactive, PMF.bind_map]
+    simp only [Function.comp_def]
+    exact PMF.bind_const _ _
+
+theorem simulateQ_originalProposalImpl_complete {μ α : Type} (key : SecretKey)
+    (spent : QueryCache HashSpec × μ → Nat) (enabled : Message → QueryCache HashSpec × μ → Bool)
+    (update : (input : (OracleWorld + SigningSpec).Domain) → QueryCache HashSpec × μ →
+      Nat → ProposalExecutionRecord input → μ)
+    (total : Nat) (computation : OracleComp (OracleWorld + SigningSpec) α)
+    (state : List Index × (QueryCache HashSpec × μ)) :
+    ((simulateQ (originalProposalImpl key spent enabled update) computation).run state).bind
+        (fun result => completeProposalWord (PMF.uniformOfFintype Index) total result.2.1) =
+      completeProposalWord (PMF.uniformOfFintype Index) total state.1 := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [simulateQ_pure, StateT.run_pure, PMF.monad_pure_eq_pure, PMF.pure_bind]
+  | query_bind input next ih =>
+      rw [simulateQ_bind, simulateQ_spec_query, StateT.run_bind, PMF.monad_bind_eq_bind, PMF.bind_bind]
+      simp_rw [ih]
+      exact originalProposalImpl_complete key spent enabled update total input state
+
+noncomputable def terminalProposalPotential {α : Type} (base : PMF α) (total : Nat)
+    (payoff : List α → ENNReal) (consumed : List α) : ENNReal :=
+  ∑' word, Pr[= word | completeProposalWord base total consumed] * payoff word
+
+theorem expected_originalProposalImpl_terminalPotential {μ : Type} (key : SecretKey)
+    (spent : QueryCache HashSpec × μ → Nat) (enabled : Message → QueryCache HashSpec × μ → Bool)
+    (update : (input : (OracleWorld + SigningSpec).Domain) → QueryCache HashSpec × μ →
+      Nat → ProposalExecutionRecord input → μ)
+    (total : Nat) (payoff : List Index → ENNReal)
+    (input : (OracleWorld + SigningSpec).Domain) (state : List Index × (QueryCache HashSpec × μ)) :
+    (∑' result, Pr[= result | (originalProposalImpl key spent enabled update input).run state] *
+        terminalProposalPotential (PMF.uniformOfFintype Index) total payoff result.2.1) =
+      terminalProposalPotential (PMF.uniformOfFintype Index) total payoff state.1 := by
+  have h := congrArg (fun law : PMF (List Index) => ∑' word, Pr[= word | law] * payoff word)
+    (originalProposalImpl_complete key spent enabled update total input state)
+  rw [← PMF.monad_bind_eq_bind, tsum_probOutput_bind_mul] at h
+  exact h
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/PairedHiddenMiss.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/PairedHiddenMiss.lean
new file mode 100644
index 000000000..99d1bd588
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/PairedHiddenMiss.lean
@@ -0,0 +1,61 @@
+import SphincsSecurity.Proof.Base.Prelude
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+variable {ι α : Type} [Fintype ι] [DecidableEq ι] [DecidableEq α]
+
+def eraseTableValue (allowed : ι → Finset α) (coordinate : ι) (candidate : α) : ι → Finset α :=
+  Function.update allowed coordinate ((allowed coordinate).erase candidate)
+
+def pairedMissAllowed (allowed : ι → Finset α) (child : ι) (candidate : α) (parent : ι) (answer : α) :
+    ι → Finset α := eraseTableValue (eraseTableValue allowed child candidate) parent answer
+
+omit [Fintype ι] in
+theorem pairedMissAllowed_membership (allowed : ι → Finset α) (child parent : ι) (hne : child ≠ parent)
+    (candidate answer : α) (table : ι → α) :
+    (∀ coordinate, table coordinate ∈ pairedMissAllowed allowed child candidate parent answer coordinate) ↔
+      (∀ coordinate, table coordinate ∈ allowed coordinate) ∧ table child ≠ candidate ∧ table parent ≠ answer := by
+  constructor
+  · intro h
+    have hchild := h child
+    have hparent := h parent
+    simp only [pairedMissAllowed, eraseTableValue, Function.update_of_ne hne, Function.update_self,
+      Function.update_of_ne hne.symm, Finset.mem_erase] at hchild hparent
+    refine ⟨?_, hchild.1, hparent.1⟩
+    intro coordinate
+    by_cases hp : coordinate = parent
+    · simpa only [hp] using hparent.2
+    by_cases hc : coordinate = child
+    · simpa only [hc] using hchild.2
+    simpa only [pairedMissAllowed, eraseTableValue, Function.update_of_ne hp, Function.update_of_ne hc] using h coordinate
+  · rintro ⟨h, hc, hp⟩ coordinate
+    by_cases heqp : coordinate = parent
+    · subst coordinate
+      simp only [pairedMissAllowed, eraseTableValue, Function.update_self, Function.update_of_ne hne.symm,
+        Finset.mem_erase]
+      exact ⟨hp, h parent⟩
+    by_cases heqc : coordinate = child
+    · subst coordinate
+      simp only [pairedMissAllowed, eraseTableValue, Function.update_of_ne hne, Function.update_self, Finset.mem_erase]
+      exact ⟨hc, h child⟩
+    simpa only [pairedMissAllowed, eraseTableValue, Function.update_of_ne heqp, Function.update_of_ne heqc] using h coordinate
+
+omit [Fintype ι] in
+theorem pairedMissAllowed_card_lower (allowed : ι → Finset α) (child parent : ι) (hne : child ≠ parent)
+    (candidate answer : α) (coordinate : ι) :
+    (allowed coordinate).card - 1 ≤ (pairedMissAllowed allowed child candidate parent answer coordinate).card := by
+  by_cases hp : coordinate = parent
+  · subst coordinate
+    simpa only [pairedMissAllowed, eraseTableValue, Function.update_self, Function.update_of_ne hne.symm] using
+      (Finset.pred_card_le_card_erase (s := allowed parent) (a := answer))
+  by_cases hc : coordinate = child
+  · subst coordinate
+    simpa only [pairedMissAllowed, eraseTableValue, Function.update_of_ne hne, Function.update_self] using
+      (Finset.pred_card_le_card_erase (s := allowed child) (a := candidate))
+  simpa only [pairedMissAllowed, eraseTableValue, Function.update_of_ne hp, Function.update_of_ne hc] using
+    Nat.sub_le (allowed coordinate).card 1
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/PrimitiveMessagePotential.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/PrimitiveMessagePotential.lean
new file mode 100644
index 000000000..3ec971111
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/PrimitiveMessagePotential.lean
@@ -0,0 +1,147 @@
+import SphincsSecurity.Proof.Base.Prelude
+namespace SphincsSecurity.Concrete.PrimitiveMessagePotential
+
+noncomputable def value (space probes remaining : ℝ) : ℝ :=
+  1 - ((space - probes - remaining) / (space - probes)) ^ 2
+
+theorem initial (space budget : ℝ) (hspace : space ≠ 0) :
+    value space 0 budget = 2 * (budget / space) - (budget / space) ^ 2 := by
+  unfold value
+  simp only [sub_zero]
+  field_simp
+  ring
+
+theorem probe_balance (space probes remaining : ℝ)
+    (hspace : space - probes ≠ 0) (hnext : space - (probes + 1) ≠ 0) :
+    value space probes 1 + (1 - value space probes 1) * value space (probes + 1) remaining =
+      value space probes (remaining + 1) := by
+  unfold value
+  field_simp
+  ring
+
+theorem hazard (space probes : ℝ) (hspace : space - probes ≠ 0) :
+    value space probes 1 = 1 - (1 - (space - probes)⁻¹) ^ 2 := by
+  unfold value
+  field_simp
+
+theorem toReal_hazard (space probes : Nat) (hprobes : probes < space) :
+    (1 - (1 - ((space - probes : Nat) : ENNReal)⁻¹) ^ 2 : ENNReal).toReal = value space probes 1 := by
+  have hminimum : 1 ≤ space - probes := Nat.sub_pos_of_lt hprobes
+  have hinverse : ((space - probes : Nat) : ENNReal)⁻¹ ≤ 1 := by
+    apply ENNReal.inv_le_one.mpr
+    exact_mod_cast hminimum
+  have hsub : (1 - ((space - probes : Nat) : ENNReal)⁻¹ : ENNReal) ≤ 1 := tsub_le_self
+  have hsquare : (1 - ((space - probes : Nat) : ENNReal)⁻¹) ^ 2 ≤ (1 : ENNReal) := by
+    simpa only [pow_two, mul_one] using mul_le_mul' hsub hsub
+  have hden : (space : ℝ) - probes ≠ 0 := ne_of_gt (sub_pos.mpr (Nat.cast_lt.mpr hprobes))
+  rw [ENNReal.toReal_sub_of_le hsquare (by simp), ENNReal.toReal_one, ENNReal.toReal_pow,
+    ENNReal.toReal_sub_of_le hinverse (by simp), ENNReal.toReal_one, ENNReal.toReal_inv,
+    ENNReal.toReal_natCast, Nat.cast_sub hprobes.le, hazard _ _ hden]
+
+theorem bounds (space probes remaining : ℝ) (hremaining : 0 ≤ remaining)
+    (hbudget : probes + remaining < space) :
+    0 ≤ value space probes remaining ∧ value space probes remaining < 1 := by
+  have hden : 0 < space - probes := by linarith
+  have hnum : 0 < space - probes - remaining := by linarith
+  have hratio : 0 < (space - probes - remaining) / (space - probes) := div_pos hnum hden
+  have hone : (space - probes - remaining) / (space - probes) ≤ 1 := by
+    apply (div_le_one₀ hden).mpr
+    linarith
+  unfold value
+  constructor
+  · nlinarith [sq_nonneg ((space - probes - remaining) / (space - probes)),
+      mul_self_le_mul_self hratio.le hone]
+  · nlinarith [sq_pos_of_pos hratio]
+
+theorem message_increment (space probes remaining : ℝ) (hspace : space - probes ≠ 0) :
+    value space probes (remaining + 1) - value space probes remaining =
+      (2 * (space - probes - remaining) - 1) / (space - probes) ^ 2 := by
+  unfold value
+  field_simp
+  ring
+
+theorem message_payment (space probes remaining : ℝ) (hspace : 0 < space)
+    (hprobes : 0 ≤ probes) (hremaining : 0 ≤ remaining)
+    (hbudget : 2 * (probes + remaining + 1) ≤ space) :
+    1 / space + value space probes remaining ≤ value space probes (remaining + 1) := by
+  have hden : 0 < space - probes := by linarith
+  have hnum : space ≤ 2 * (space - probes - remaining) - 1 := by linarith
+  have hsq : (space - probes) ^ 2 ≤ space ^ 2 := by nlinarith
+  have hpay : 1 / space ≤ (2 * (space - probes - remaining) - 1) / (space - probes) ^ 2 := by
+    calc
+      1 / space = space / space ^ 2 := by field_simp
+      _ ≤ space / (space - probes) ^ 2 := div_le_div_of_nonneg_left hspace.le (sq_pos_of_pos hden) hsq
+      _ ≤ _ := (div_le_div_iff_of_pos_right (sq_pos_of_pos hden)).mpr hnum
+  rw [← message_increment space probes remaining (ne_of_gt hden)] at hpay
+  linarith
+
+theorem mono_remaining (space probes before after : ℝ) (hbefore : 0 ≤ before)
+    (horder : before ≤ after) (hbudget : probes + after < space) :
+    value space probes before ≤ value space probes after := by
+  have hden : 0 < space - probes := by linarith
+  have hsmall : 0 ≤ (space - probes - after) / (space - probes) := div_nonneg (by linarith) hden.le
+  have hratio : (space - probes - after) / (space - probes) ≤ (space - probes - before) / (space - probes) :=
+    (div_le_div_iff_of_pos_right hden).mpr (by linarith)
+  unfold value
+  nlinarith [mul_self_le_mul_self hsmall hratio]
+
+theorem mono_probes (space before after remaining : ℝ) (hremaining : 0 ≤ remaining)
+    (horder : before ≤ after) (hbudget : after + remaining < space) :
+    value space before remaining ≤ value space after remaining := by
+  have hafter : 0 < space - after := by linarith
+  have hbefore : 0 < space - before := by linarith
+  have hquot : remaining / (space - before) ≤ remaining / (space - after) :=
+    div_le_div_of_nonneg_left hremaining hafter (by linarith)
+  have hratio (probes : ℝ) (hden : space - probes ≠ 0) :
+      (space - probes - remaining) / (space - probes) = 1 - remaining / (space - probes) := by
+    field_simp
+  have hnonnegative : 0 ≤ 1 - remaining / (space - after) := by
+    have hle := (div_le_one₀ hafter).mpr (show remaining ≤ space - after by linarith)
+    linarith
+  unfold value
+  rw [hratio before hbefore.ne', hratio after hafter.ne']
+  nlinarith [mul_self_le_mul_self hnonnegative (show 1 - remaining / (space - after) ≤
+    1 - remaining / (space - before) by linarith)]
+
+theorem nonmessage_step (space probes after remaining probability : ℝ)
+    (hremaining : 0 ≤ remaining) (hafter : after ≤ probes + 1) (hbudget : probes + remaining + 1 < space)
+    (hhazard : probability ≤ value space probes 1) :
+    probability + (1 - probability) * value space after remaining ≤ value space probes (remaining + 1) := by
+  have hnext := bounds space (probes + 1) remaining hremaining (by linarith)
+  have hfirst := bounds space probes 1 (by norm_num) (by linarith)
+  have hcontinuation := mono_probes space after (probes + 1) remaining hremaining hafter (by linarith)
+  have hsurvive : 0 ≤ 1 - probability := by linarith
+  calc
+    _ ≤ probability + (1 - probability) * value space (probes + 1) remaining :=
+      add_le_add le_rfl (mul_le_mul_of_nonneg_left hcontinuation hsurvive)
+    _ ≤ value space probes 1 + (1 - value space probes 1) * value space (probes + 1) remaining := by
+      nlinarith [mul_nonneg (sub_nonneg.mpr hhazard) (sub_nonneg.mpr hnext.2.le)]
+    _ = _ := probe_balance space probes remaining (by linarith) (by linarith)
+
+theorem messages_payment (space probes remaining : ℝ) (calls : Nat) (hspace : 0 < space)
+    (hprobes : 0 ≤ probes) (hremaining : 0 ≤ remaining) (hbudget : 2 * (probes + remaining + calls) ≤ space) :
+    (calls : ℝ) / space + value space probes remaining ≤ value space probes (remaining + calls) := by
+  induction calls with
+  | zero => simp
+  | succ calls ih =>
+      have hcast : ((calls + 1 : Nat) : ℝ) = (calls : ℝ) + 1 := by push_cast; rfl
+      rw [hcast] at hbudget ⊢
+      have hbefore := ih (by linarith)
+      have hlast := message_payment space probes (remaining + calls) hspace hprobes
+        (by positivity) (by linarith)
+      have heq : remaining + ((calls : ℝ) + 1) = (remaining + calls) + 1 := by ring
+      rw [heq]
+      calc
+        _ = 1 / space + ((calls : ℝ) / space + value space probes remaining) := by ring
+        _ ≤ 1 / space + value space probes (remaining + calls) := add_le_add le_rfl hbefore
+        _ ≤ _ := hlast
+
+theorem work_payment (space probes remaining : ℝ) (messages cost : Nat) (hspace : 0 < space)
+    (hprobes : 0 ≤ probes) (hremaining : 0 ≤ remaining) (hcost : messages ≤ cost)
+    (hbudget : 2 * (probes + remaining + cost) ≤ space) :
+    (messages : ℝ) / space + value space probes remaining ≤ value space probes (remaining + cost) := by
+  have hm : (messages : ℝ) ≤ cost := by exact_mod_cast hcost
+  exact (add_le_add (div_le_div_of_nonneg_right hm hspace.le) le_rfl).trans
+    (messages_payment space probes remaining cost hspace hprobes hremaining hbudget)
+
+end SphincsSecurity.Concrete.PrimitiveMessagePotential
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/ProposalBridgeKernel.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/ProposalBridgeKernel.lean
new file mode 100644
index 000000000..4719a1d62
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/ProposalBridgeKernel.lean
@@ -0,0 +1,200 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.ProposalWordDistribution
+namespace SphincsSecurity.Concrete
+
+open ENNReal
+attribute [local instance] Classical.propDecidable
+
+theorem proposalResidual_sum {α : Type*} (base target : PMF α) (accept : ENNReal)
+    (hcap : ∀ index : α, accept * target index ≤ base index) :
+    (∑' index : α, (base index - accept * target index)) = 1 - accept := by
+  apply ENNReal.eq_sub_of_add_eq' (by finiteness)
+  calc
+    _ = ∑' index : α, ((base index - accept * target index) + accept * target index) := by
+      rw [ENNReal.tsum_add, ENNReal.tsum_mul_left, target.tsum_coe, mul_one]
+    _ = ∑' index, base index := tsum_congr (fun index => tsub_add_cancel_of_le (hcap index))
+    _ = 1 := base.tsum_coe
+
+noncomputable def proposalResidualLaw {α : Type*} (base target : PMF α) (accept : ENNReal)
+    (hlt : accept < 1) (hcap : ∀ index, accept * target index ≤ base index) : PMF α :=
+  PMF.normalize (fun index => base index - accept * target index)
+    (by rw [proposalResidual_sum base target accept hcap]; exact ne_of_gt (tsub_pos_iff_lt.mpr hlt))
+    (by rw [proposalResidual_sum base target accept hcap]; finiteness)
+
+theorem proposalResidualLaw_apply {α : Type*} (base target : PMF α) (accept : ENNReal)
+    (hlt : accept < 1) (hcap : ∀ index, accept * target index ≤ base index) (index : α) :
+    proposalResidualLaw base target accept hlt hcap index =
+      (base index - accept * target index) * (1 - accept)⁻¹ := by
+  simp only [proposalResidualLaw, PMF.normalize_apply, proposalResidual_sum base target accept hcap]
+
+theorem proposalResidualLaw_scaled {α : Type*} (base target : PMF α) (accept : ENNReal)
+    (hlt : accept < 1) (hcap : ∀ index, accept * target index ≤ base index) (index : α) :
+    (1 - accept) * proposalResidualLaw base target accept hlt hcap index = base index - accept * target index := by
+  rw [proposalResidualLaw_apply]
+  calc
+    _ = (base index - accept * target index) * ((1 - accept) * (1 - accept)⁻¹) := by ring
+    _ = _ := by
+      rw [ENNReal.mul_inv_cancel (ne_of_gt (tsub_pos_iff_lt.mpr hlt)) (by finiteness), mul_one]
+
+noncomputable def proposalAcceptanceCoin (accept : ENNReal) (hle : accept ≤ 1) : PMF Bool :=
+  PMF.ofFintype (fun accepted => if accepted then accept else 1 - accept) (by
+    simp only [Fintype.sum_bool, Bool.false_eq_true, if_false, if_true]
+    exact (add_comm _ _).trans (tsub_add_cancel_of_le hle))
+
+theorem proposalAcceptanceCoin_bind_apply {Ω : Type*} (accept : ENNReal) (hle : accept ≤ 1)
+    (continuation : Bool → PMF Ω) (outcome : Ω) :
+    (proposalAcceptanceCoin accept hle).bind continuation outcome =
+      (1 - accept) * continuation false outcome + accept * continuation true outcome := by
+  rw [PMF.bind_apply, tsum_fintype]
+  simp only [Fintype.sum_bool, proposalAcceptanceCoin, PMF.ofFintype_apply, Bool.false_eq_true, if_false, if_true]
+  exact add_comm _ _
+
+noncomputable def proposalRecordStep {α Ω : Type*} (base : PMF α) (record : PMF Ω) (label : Ω → α)
+    (accept : ENNReal) (hlt : accept < 1) (hcap : ∀ index, accept * (record.map label) index ≤ base index) : PMF (α ⊕ Ω) :=
+  (proposalAcceptanceCoin accept hlt.le).bind fun accepted =>
+    if accepted then record.map Sum.inr
+    else (proposalResidualLaw base (record.map label) accept hlt hcap).map Sum.inl
+
+theorem proposalRecordStep_reject {α Ω : Type*} (base : PMF α) (record : PMF Ω) (label : Ω → α)
+    (accept : ENNReal) (hlt : accept < 1) (hcap : ∀ index, accept * (record.map label) index ≤ base index) (index : α) :
+    proposalRecordStep base record label accept hlt hcap (.inl index) = base index - accept * (record.map label) index := by
+  letI : DecidableEq α := Classical.decEq α
+  letI : DecidableEq Ω := Classical.decEq Ω
+  rw [proposalRecordStep, proposalAcceptanceCoin_bind_apply]
+  simp only [Bool.false_eq_true, if_false, if_true, PMF.map_apply, Sum.inl.injEq, Sum.inl_ne_inr,
+    tsum_ite_eq', if_false, tsum_zero, mul_zero, add_zero, proposalResidualLaw_scaled]
+
+theorem proposalRecordStep_accept {α Ω : Type*} (base : PMF α) (record : PMF Ω) (label : Ω → α)
+    (accept : ENNReal) (hlt : accept < 1) (hcap : ∀ index, accept * (record.map label) index ≤ base index) (outcome : Ω) :
+    proposalRecordStep base record label accept hlt hcap (.inr outcome) = accept * record outcome := by
+  letI : DecidableEq α := Classical.decEq α
+  letI : DecidableEq Ω := Classical.decEq Ω
+  rw [proposalRecordStep, proposalAcceptanceCoin_bind_apply]
+  simp only [Bool.false_eq_true, if_false, if_true, PMF.map_apply, Sum.inr.injEq, Sum.inr_ne_inl,
+    tsum_ite_eq', if_false, tsum_zero, mul_zero, zero_add]
+
+theorem proposalRecordStep_label {α Ω : Type*} (base : PMF α) (record : PMF Ω) (label : Ω → α)
+    (accept : ENNReal) (hlt : accept < 1) (hcap : ∀ index, accept * (record.map label) index ≤ base index) :
+    (proposalRecordStep base record label accept hlt hcap).map (Sum.elim id label) = base := by
+  unfold proposalRecordStep
+  rw [PMF.map_bind]
+  have hbranch (accepted : Bool) :
+      (if accepted then record.map Sum.inr
+        else (proposalResidualLaw base (record.map label) accept hlt hcap).map Sum.inl).map (Sum.elim id label) =
+      if accepted then record.map label else proposalResidualLaw base (record.map label) accept hlt hcap := by
+    cases accepted <;> simp only [Bool.false_eq_true, if_false, if_true, PMF.map_comp, Function.comp_def, Sum.elim_inl,
+      Sum.elim_inr, id_eq]
+    exact PMF.map_id _
+  simp_rw [hbranch]
+  ext index
+  rw [proposalAcceptanceCoin_bind_apply]
+  simp only [Bool.false_eq_true, if_false, if_true, proposalResidualLaw_scaled, tsub_add_cancel_of_le (hcap index)]
+
+noncomputable def cappedRecordProposalBridge {α Ω : Type*} (base : PMF α) (record : PMF Ω) (label : Ω → α)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hlt : accept < 1)
+    (hcap : ∀ index, accept * (record.map label) index ≤ base index) : PMF (List α × Ω) :=
+  recordProposalBridge record (proposalResidualLaw base (record.map label) accept hlt hcap) accept hpos hlt.le
+
+theorem cappedRecordProposalBridge_nil {α Ω : Type*} (base : PMF α) (record : PMF Ω) (label : Ω → α)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hlt : accept < 1)
+    (hcap : ∀ index, accept * (record.map label) index ≤ base index) (outcome : Ω) :
+    cappedRecordProposalBridge base record label accept hpos hlt hcap ([], outcome) =
+      proposalRecordStep base record label accept hlt hcap (.inr outcome) := by
+  rw [cappedRecordProposalBridge, recordProposalBridge_nil, proposalRecordStep_accept]
+
+theorem cappedRecordProposalBridge_cons {α Ω : Type*} (base : PMF α) (record : PMF Ω) (label : Ω → α)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hlt : accept < 1)
+    (hcap : ∀ index, accept * (record.map label) index ≤ base index) (head : α) (rest : List α) (outcome : Ω) :
+    cappedRecordProposalBridge base record label accept hpos hlt hcap (head :: rest, outcome) =
+      proposalRecordStep base record label accept hlt hcap (.inl head) *
+        cappedRecordProposalBridge base record label accept hpos hlt hcap (rest, outcome) := by
+  rw [cappedRecordProposalBridge, recordProposalBridge_cons, proposalResidualLaw_scaled, proposalRecordStep_reject]
+
+def prependProposalRecord {α Ω : Type*} (head : α) (result : List α × Ω) : List α × Ω :=
+  (head :: result.1, result.2)
+
+private theorem prependProposalRecord_apply {α Ω : Type*} [DecidableEq α]
+    (law : PMF (List α × Ω)) (head : α) (word : List α) (outcome : Ω) :
+    (law.map (prependProposalRecord head)) (word, outcome) =
+      match word with
+      | [] => 0
+      | next :: rest => if next = head then law (rest, outcome) else 0 := by
+  cases word with
+  | nil =>
+      apply pmf_map_apply_zero_of_not_image
+      intro source heq
+      have h := congrArg Prod.fst heq
+      change [] = head :: source.1 at h
+      cases h
+  | cons next rest =>
+      change (law.map (prependProposalRecord head)) (next :: rest, outcome) =
+        if next = head then law (rest, outcome) else 0
+      by_cases h : next = head
+      · subst next
+        rw [if_pos rfl]
+        apply pmf_map_injective_apply law (prependProposalRecord head) _ (rest, outcome)
+        intro left right h
+        have hfirst := congrArg Prod.fst h
+        have hsecond := congrArg Prod.snd h
+        change head :: left.1 = head :: right.1 at hfirst
+        change left.2 = right.2 at hsecond
+        exact Prod.ext (List.cons.inj hfirst).2 hsecond
+      · rw [if_neg h]
+        exact pmf_map_apply_zero_of_not_image _ _ _
+          (fun source heq => h (List.cons.inj (congrArg Prod.fst heq)).1)
+
+noncomputable def proposalBridgeContinuation {α Ω : Type*} (law : PMF (List α × Ω)) : α ⊕ Ω → PMF (List α × Ω)
+  | .inl head => law.map (prependProposalRecord head)
+  | .inr outcome => PMF.pure ([], outcome)
+
+theorem cappedRecordProposalBridge_step {α Ω : Type*} (base : PMF α) (record : PMF Ω) (label : Ω → α)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hlt : accept < 1)
+    (hcap : ∀ index, accept * (record.map label) index ≤ base index) :
+    cappedRecordProposalBridge base record label accept hpos hlt hcap =
+      (proposalRecordStep base record label accept hlt hcap).bind
+        (proposalBridgeContinuation (cappedRecordProposalBridge base record label accept hpos hlt hcap)) := by
+  letI : DecidableEq α := Classical.decEq α
+  let law := cappedRecordProposalBridge base record label accept hpos hlt hcap
+  let rejected := proposalResidualLaw base (record.map label) accept hlt hcap
+  have hexpand : (proposalRecordStep base record label accept hlt hcap).bind (proposalBridgeContinuation law) =
+      (proposalAcceptanceCoin accept hlt.le).bind (fun accepted =>
+        if accepted then record.map (fun outcome => ([], outcome))
+        else rejected.bind (fun head => law.map (prependProposalRecord head))) := by
+    rw [proposalRecordStep, PMF.bind_bind]
+    apply congrArg (PMF.bind (proposalAcceptanceCoin accept hlt.le))
+    funext accepted
+    cases accepted <;> simp only [Bool.false_eq_true, if_false, if_true, PMF.bind_map,
+      Function.comp_def, proposalBridgeContinuation]
+    all_goals rfl
+  change law = _
+  rw [hexpand]
+  ext result
+  rcases result with ⟨word, outcome⟩
+  rw [proposalAcceptanceCoin_bind_apply]
+  simp only [Bool.false_eq_true, if_false, if_true]
+  have hrej : (rejected.bind (fun head => law.map (prependProposalRecord head))) (word, outcome) =
+      match word with
+      | [] => 0
+      | next :: rest => rejected next * law (rest, outcome) := by
+    rw [PMF.bind_apply]
+    simp only [prependProposalRecord_apply]
+    cases word <;> simp only [mul_zero, tsum_zero, mul_ite, tsum_ite_eq']
+  rw [hrej]
+  cases word with
+  | nil =>
+      rw [pmf_map_injective_apply record (fun outcome => ([], outcome))
+        (fun _ _ h => congrArg Prod.snd h) outcome, mul_zero, zero_add]
+      exact (cappedRecordProposalBridge_nil base record label accept hpos hlt hcap outcome).trans
+        (proposalRecordStep_accept base record label accept hlt hcap outcome)
+  | cons head rest =>
+      have hacc : (record.map (fun outcome => ([], outcome))) (head :: rest, outcome) = 0 :=
+        pmf_map_apply_zero_of_not_image _ _ _ (fun _ heq => by
+          have h := congrArg Prod.fst heq
+          change head :: rest = [] at h
+          cases h)
+      rw [hacc, mul_zero, add_zero]
+      change cappedRecordProposalBridge base record label accept hpos hlt hcap (head :: rest, outcome) = _
+      rw [cappedRecordProposalBridge_cons, proposalRecordStep_reject, ← proposalResidualLaw_scaled base (record.map label) accept hlt hcap head]
+      exact mul_assoc _ _ _
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/ProposalLengthProjection.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/ProposalLengthProjection.lean
new file mode 100644
index 000000000..7e5476613
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/ProposalLengthProjection.lean
@@ -0,0 +1,89 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.SigningProposalRecord
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+
+theorem independentProposalWord_length {α : Type*} (law : PMF α) (steps : Nat) :
+    (independentProposalWord law steps).map List.length = PMF.pure steps := by
+  induction steps with
+  | zero => exact PMF.pure_map _ _
+  | succ steps ih =>
+      rw [independentProposalWord, PMF.map_bind]
+      have hbranch (head : α) :
+          ((independentProposalWord law steps).map (head :: ·)).map List.length =
+            PMF.pure (steps + 1) := by
+        calc
+          _ = ((independentProposalWord law steps).map List.length).map Nat.succ := by
+            rw [PMF.map_comp, PMF.map_comp]
+            rfl
+          _ = _ := by rw [ih, PMF.pure_map]
+      simp_rw [hbranch]
+      exact PMF.bind_const _ _
+
+theorem rejectedProposalWord_length {α : Type*} (law : PMF α)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hle : accept ≤ 1) :
+    (rejectedProposalWord law accept hpos hle).map List.length =
+      proposalFailureCount accept hpos hle := by
+  rw [rejectedProposalWord, PMF.map_bind]
+  simp_rw [independentProposalWord_length]
+  exact PMF.bind_pure _
+
+noncomputable def proposalBlockLength (accept : ENNReal) (hpos : accept ≠ 0)
+    (hle : accept ≤ 1) : PMF Nat :=
+  (proposalFailureCount accept hpos hle).map Nat.succ
+
+theorem proposalBlockLength_zero (accept : ENNReal) (hpos : accept ≠ 0) (hle : accept ≤ 1) :
+    proposalBlockLength accept hpos hle 0 = 0 :=
+  pmf_map_apply_zero_of_not_image _ _ _ (fun _ => Nat.zero_ne_add_one _)
+
+theorem proposalBlockLength_succ (accept : ENNReal) (hpos : accept ≠ 0) (hle : accept ≤ 1)
+    (failures : Nat) :
+    proposalBlockLength accept hpos hle (failures + 1) = accept * (1 - accept) ^ failures :=
+  (pmf_map_injective_apply _ _ Nat.succ_injective failures).trans rfl
+
+theorem rejectedProposalWord_blockLength {α : Type*} (law : PMF α)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hle : accept ≤ 1) :
+    (rejectedProposalWord law accept hpos hle).map (fun word => word.length + 1) =
+      proposalBlockLength accept hpos hle := by
+  change _ = ((proposalFailureCount accept hpos hle).map Nat.succ)
+  rw [← rejectedProposalWord_length law accept hpos hle, PMF.map_comp]
+  rfl
+
+noncomputable def recordLengthBridge {Ω : Type*} (record : PMF Ω)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hle : accept ≤ 1) : PMF (Nat × Ω) :=
+  record.bind fun outcome =>
+    (proposalBlockLength accept hpos hle).map (fun length => (length, outcome))
+
+theorem recordProposalBridge_length_record {α Ω : Type*} (record : PMF Ω) (rejected : PMF α)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hle : accept ≤ 1) :
+    (recordProposalBridge record rejected accept hpos hle).map
+      (fun result => (result.1.length + 1, result.2)) = recordLengthBridge record accept hpos hle := by
+  rw [recordProposalBridge, PMF.map_bind]
+  have hbranch (outcome : Ω) :
+      ((rejectedProposalWord rejected accept hpos hle).map (fun word => (word, outcome))).map
+        (fun result => (result.1.length + 1, result.2)) =
+      (proposalBlockLength accept hpos hle).map (fun length => (length, outcome)) := by
+    rw [← rejectedProposalWord_blockLength rejected accept hpos hle, PMF.map_comp, PMF.map_comp]
+    rfl
+  simp_rw [hbranch]
+  rfl
+
+theorem recordLengthBridge_record {Ω : Type*} (record : PMF Ω)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hle : accept ≤ 1) :
+    (recordLengthBridge record accept hpos hle).map Prod.snd = record := by
+  rw [recordLengthBridge, PMF.map_bind]
+  simp only [PMF.map_comp, Function.comp_def]
+  change (record.bind fun outcome =>
+    (proposalBlockLength accept hpos hle).map (Function.const Nat outcome)) = record
+  simp only [PMF.map_const, PMF.bind_pure]
+
+theorem recordLengthBridge_length {Ω : Type*} (record : PMF Ω)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hle : accept ≤ 1) :
+    (recordLengthBridge record accept hpos hle).map Prod.fst = proposalBlockLength accept hpos hle := by
+  rw [recordLengthBridge, PMF.map_bind]
+  simp only [PMF.map_comp, Function.comp_def]
+  change (record.bind fun _ => (proposalBlockLength accept hpos hle).map id) = _
+  rw [PMF.map_id, PMF.bind_const]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/ProposalPrefixExponential.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/ProposalPrefixExponential.lean
new file mode 100644
index 000000000..0d65ba1a7
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/ProposalPrefixExponential.lean
@@ -0,0 +1,126 @@
+import SphincsSecurity.Proof.Fts.CertificateProposalPrefixException
+import Mathlib.Analysis.Complex.ExponentialBounds
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp ENNReal
+
+noncomputable def proposalTailBase : ENNReal := 257 / 256
+noncomputable def proposalTailMoment : ENNReal := 67634176 / 66845695
+
+theorem proposalBlockLength_power_moment (accept : ENNReal) (hpos : accept ≠ 0) (hle : accept ≤ 1) (base : ENNReal) :
+    (∑' length, proposalBlockLength accept hpos hle length * base ^ length) =
+      accept * base / (1 - (1 - accept) * base) := by
+  rw [tsum_eq_zero_add' ENNReal.summable, proposalBlockLength_zero, zero_mul, zero_add]
+  simp only [proposalBlockLength_succ, pow_succ]
+  calc
+    _ = ∑' failures, (accept * base) * ((1 - accept) * base) ^ failures := by
+      apply tsum_congr
+      intro failures
+      rw [mul_pow]
+      ac_rfl
+    _ = _ := by rw [ENNReal.tsum_mul_left, ENNReal.tsum_geometric]; rfl
+
+theorem proposalTailMoment_eq : proposalTailMoment =
+    targetProposalAcceptance * proposalTailBase ^ 2 / (1 - (1 - targetProposalAcceptance) * proposalTailBase ^ 2) := by
+  have hrem : (1 - targetProposalAcceptance).toReal = 1 - targetProposalAcceptance.toReal := by
+    rw [ENNReal.toReal_sub_of_le targetProposalAcceptance_lt_one.le (by finiteness), ENNReal.toReal_one]
+  have hlt : (1 - targetProposalAcceptance) * proposalTailBase ^ 2 < 1 := by
+    apply (ENNReal.toReal_lt_toReal (by unfold proposalTailBase; finiteness) (by finiteness)).mp
+    rw [ENNReal.toReal_mul, hrem]
+    norm_num [ENNReal.toReal_pow, targetProposalAcceptance, targetProposalOverhead,
+      proposalTailBase, ENNReal.toReal_inv, ENNReal.toReal_div]
+  have hnz : 1 - (1 - targetProposalAcceptance) * proposalTailBase ^ 2 ≠ 0 := (tsub_pos_iff_lt.mpr hlt).ne'
+  have haccept : targetProposalAcceptance ≠ ⊤ := ne_top_of_le_ne_top (by finiteness) targetProposalAcceptance_lt_one.le
+  apply (ENNReal.toReal_eq_toReal_iff' (by unfold proposalTailMoment; finiteness)
+    (ENNReal.div_ne_top (ENNReal.mul_ne_top haccept (by unfold proposalTailBase; finiteness)) hnz)).mp
+  rw [ENNReal.toReal_div, ENNReal.toReal_sub_of_le hlt.le (by finiteness)]
+  simp only [ENNReal.toReal_mul, hrem]
+  norm_num [proposalTailMoment, ENNReal.toReal_pow, targetProposalAcceptance,
+    targetProposalOverhead, proposalTailBase, ENNReal.toReal_inv, ENNReal.toReal_div]
+
+theorem proposalTailMoment_ge_cube : proposalTailBase ^ 3 ≤ proposalTailMoment := by
+  apply (ENNReal.toReal_le_toReal (by unfold proposalTailBase; finiteness) (by unfold proposalTailMoment; finiteness)).mp
+  norm_num [proposalTailBase, proposalTailMoment, ENNReal.toReal_pow, ENNReal.toReal_div]
+
+theorem proposalTailBase_one_le : 1 ≤ proposalTailBase := by
+  apply (ENNReal.toReal_le_toReal (by finiteness) (by unfold proposalTailBase; finiteness)).mp
+  norm_num [proposalTailBase, ENNReal.toReal_div]
+
+noncomputable def proposalPrefixWeight (proposals completed : Nat) : ENNReal :=
+  proposalTailBase ^ (2 * proposals) * proposalTailMoment ^ (signatureLimit - completed) /
+    proposalTailBase ^ (3 * signatureLimit + 262144)
+
+theorem proposalPrefixWeight_bad (proposals completed : Nat) (hcap : completed ≤ signatureLimit)
+    (hbad : ProposalPrefixExceptional proposals completed) : 1 ≤ proposalPrefixWeight proposals completed := by
+  have hcount : 3 * completed + 262144 ≤ 2 * proposals := by
+    have h := (ENNReal.toReal_lt_toReal (by unfold targetProposalOverhead; finiteness) (by finiteness)).mpr hbad
+    rw [ENNReal.toReal_add (by unfold targetProposalOverhead; finiteness) (by finiteness), ENNReal.toReal_mul] at h
+    norm_num [targetProposalOverhead, ENNReal.toReal_div] at h
+    have hc : (0 : ℝ) ≤ completed := Nat.cast_nonneg _
+    have h' : (3 : ℝ) * completed + 262144 ≤ 2 * proposals := by linarith
+    exact_mod_cast h'
+  have hexp : 3 * signatureLimit + 262144 ≤ 2 * proposals + 3 * (signatureLimit - completed) := by omega
+  have hbase : proposalTailBase ≠ 0 := by norm_num [proposalTailBase]
+  have hfinite : proposalTailBase ≠ ⊤ := by unfold proposalTailBase; finiteness
+  rw [proposalPrefixWeight]
+  calc
+    1 = proposalTailBase ^ (3 * signatureLimit + 262144) /
+        proposalTailBase ^ (3 * signatureLimit + 262144) := (ENNReal.div_self (pow_ne_zero _ hbase) (by finiteness)).symm
+    _ ≤ _ := ENNReal.div_le_div_right (calc
+      _ ≤ proposalTailBase ^ (2 * proposals + 3 * (signatureLimit - completed)) :=
+        pow_le_pow_right₀ proposalTailBase_one_le hexp
+      _ = proposalTailBase ^ (2 * proposals) * (proposalTailBase ^ 3) ^ (signatureLimit - completed) := by simp only [pow_add, pow_mul]
+      _ ≤ _ := mul_le_mul' le_rfl (pow_le_pow_left₀ (by positivity) proposalTailMoment_ge_cube _)) _
+
+theorem expected_proposalPrefixWeight (proposals completed : Nat) (hcap : completed < signatureLimit) :
+    (∑' length, proposalBlockLength targetProposalAcceptance targetProposalAcceptance_ne_zero targetProposalAcceptance_lt_one.le length *
+      proposalPrefixWeight (proposals + length) (completed + 1)) = proposalPrefixWeight proposals completed := by
+  have hremaining : signatureLimit - completed = (signatureLimit - (completed + 1)) + 1 := by omega
+  simp only [proposalPrefixWeight, Nat.mul_add]
+  calc
+    _ = (proposalTailBase ^ (2 * proposals) * proposalTailMoment ^ (signatureLimit - (completed + 1)) /
+        proposalTailBase ^ (3 * signatureLimit + 262144)) *
+        ∑' length, proposalBlockLength targetProposalAcceptance targetProposalAcceptance_ne_zero targetProposalAcceptance_lt_one.le length *
+          (proposalTailBase ^ 2) ^ length := by
+      rw [← ENNReal.tsum_mul_left]
+      apply tsum_congr
+      intro length
+      simp only [pow_add, pow_mul, div_eq_mul_inv]
+      ac_rfl
+    _ = _ := by
+      rw [proposalBlockLength_power_moment, ← proposalTailMoment_eq, hremaining]
+      simp only [pow_add, pow_one, div_eq_mul_inv]
+      ac_rfl
+
+theorem proposalPrefixWeight_initial_le : proposalPrefixWeight 0 0 ≤ (2 ^ 700 : ENNReal)⁻¹ := by
+  let z : ℝ := 257 / 256
+  let ratio : ℝ := 17179869184 / 17179343615
+  have hz : 0 < z := by norm_num [z]
+  have hr : 0 < ratio := by norm_num [ratio]
+  have hlog : (signatureLimit : ℝ) * Real.log ratio - 262144 * Real.log z ≤ -700 * Real.log 2 := by
+    have hratio := Real.log_le_sub_one_of_pos hr
+    have hbase := Real.one_sub_inv_le_log_of_pos hz
+    have htwo := Real.log_two_lt_d9
+    norm_num [ratio, z, signatureLimit] at hratio hbase ⊢
+    linarith
+  have hreal : (ratio * z ^ 3) ^ signatureLimit / z ^ (3 * signatureLimit + 262144) ≤ (2 ^ 700 : ℝ)⁻¹ := by
+    apply (Real.log_le_log_iff (by positivity) (by positivity)).mp
+    rw [Real.log_div (by positivity) (by positivity), Real.log_pow, Real.log_mul hr.ne' (by positivity),
+      Real.log_pow, Real.log_pow, Real.log_inv, Real.log_pow]
+    push_cast
+    nlinarith only [hlog]
+  have hmoment : proposalTailMoment.toReal = ratio * z ^ 3 := by
+    norm_num [proposalTailMoment, ENNReal.toReal_div, ratio, z]
+  have hbase : proposalTailBase.toReal = z := by norm_num [proposalTailBase, ENNReal.toReal_div, z]
+  have hfinite : proposalPrefixWeight 0 0 ≠ ⊤ := by
+    unfold proposalPrefixWeight
+    apply ENNReal.div_ne_top
+    · exact ENNReal.mul_ne_top (ENNReal.pow_ne_top (by unfold proposalTailBase; finiteness))
+        (ENNReal.pow_ne_top (by unfold proposalTailMoment; finiteness))
+    · exact pow_ne_zero _ (by norm_num [proposalTailBase])
+  apply (ENNReal.toReal_le_toReal hfinite (by finiteness)).mp
+  simpa only [proposalPrefixWeight, Nat.mul_zero, pow_zero, one_mul, Nat.sub_zero, ENNReal.toReal_div,
+    ENNReal.toReal_pow, ENNReal.toReal_inv, ENNReal.toReal_ofNat, hmoment, hbase] using hreal
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/ProposalPrefixStop.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/ProposalPrefixStop.lean
new file mode 100644
index 000000000..46551ee02
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/ProposalPrefixStop.lean
@@ -0,0 +1,14 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CertificateTerminalGame
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def proposalPrefixStop : CertificateStopRule :=
+  fun input state length record => decide (
+    targetProposalOverhead * (state.2.log ++ signingLogFragment input record.output).length + 131072 <
+      ((state.2.proposals + length : Nat) : ENNReal))
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/ProposalQueryProjection.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/ProposalQueryProjection.lean
new file mode 100644
index 000000000..2dd5488da
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/ProposalQueryProjection.lean
@@ -0,0 +1,174 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.ProposalLengthProjection
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+
+noncomputable def pmfSumImpl {ι κ σ : Type} {leftSpec : OracleSpec ι} {rightSpec : OracleSpec κ}
+    (left : QueryImpl leftSpec (StateT σ ProbComp)) (right : QueryImpl rightSpec (StateT σ ProbComp)) :
+    QueryImpl (leftSpec + rightSpec) (StateT σ PMF)
+  | .inl input => StateT.mk fun state => liftM ((left input).run state)
+  | .inr input => StateT.mk fun state => liftM ((right input).run state)
+
+theorem pmfSumImpl_inl {ι κ σ : Type} {leftSpec : OracleSpec ι} {rightSpec : OracleSpec κ}
+    (left : QueryImpl leftSpec (StateT σ ProbComp)) (right : QueryImpl rightSpec (StateT σ ProbComp))
+    (input : leftSpec.Domain) (state : σ) :
+    (pmfSumImpl left right (.inl input)).run state = (liftM ((left input).run state) : PMF _) := rfl
+
+theorem pmfSumImpl_inr {ι κ σ : Type} {leftSpec : OracleSpec ι} {rightSpec : OracleSpec κ}
+    (left : QueryImpl leftSpec (StateT σ ProbComp)) (right : QueryImpl rightSpec (StateT σ ProbComp))
+    (input : rightSpec.Domain) (state : σ) :
+    (pmfSumImpl left right (.inr input)).run state = (liftM ((right input).run state) : PMF _) := rfl
+
+theorem pmfSumImpl_eq_lift_add {ι κ σ : Type} {leftSpec : OracleSpec ι} {rightSpec : OracleSpec κ}
+    (left : QueryImpl leftSpec (StateT σ ProbComp)) (right : QueryImpl rightSpec (StateT σ ProbComp)) :
+    pmfSumImpl left right = fun input => StateT.mk fun state =>
+      (liftM (((left + right) input).run state) : PMF _) := by
+  funext input
+  cases input <;> rfl
+
+theorem simulateQ_liftProbCompImpl_run {ι σ α : Type} {spec : OracleSpec ι}
+    (impl : QueryImpl spec (StateT σ ProbComp)) (computation : OracleComp spec α) (state : σ) :
+    (simulateQ (fun input => StateT.mk fun current => (liftM ((impl input).run current) : PMF _))
+      computation).run state = (liftM ((simulateQ impl computation).run state) : PMF _) := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value =>
+      simp only [simulateQ_pure, StateT.run_pure]
+      exact (liftM_pure (m := ProbComp) (n := PMF) _).symm
+  | query_bind input next ih =>
+      simp only [simulateQ_bind, simulateQ_query, OracleQuery.input_query, OracleQuery.cont_query,
+        id_map, StateT.run_bind, StateT.run_mk]
+      rw [liftM_bind (m := ProbComp) (n := PMF)]
+      exact congrArg (fun continuation => (liftM ((impl input).run state) : PMF _).bind continuation)
+        (funext fun result => ih result.1 result.2)
+
+noncomputable def proposalRecordImpl {ι α σ : Type} {spec : OracleSpec ι}
+    {Ω : spec.Domain → Type}
+    (record : (input : spec.Domain) → σ → PMF (Ω input))
+    (response : (input : spec.Domain) → Ω input → spec.Range input)
+    (advance : (input : spec.Domain) → σ → Nat → Ω input → σ)
+    (label : (input : spec.Domain) → Ω input → α)
+    (rejected : (input : spec.Domain) → σ → PMF α)
+    (active : spec.Domain → σ → Bool)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hle : accept ≤ 1) :
+    QueryImpl spec (StateT (List α × σ) PMF) :=
+  fun input => StateT.mk fun state =>
+    if active input state.2 then
+      (recordProposalBridge (record input state.2) (rejected input state.2) accept hpos hle).map
+        (fun result => (response input result.2,
+          (state.1 ++ result.1 ++ [label input result.2],
+            advance input state.2 (result.1.length + 1) result.2)))
+    else
+      (record input state.2).map fun outcome =>
+        (response input outcome, (state.1, advance input state.2 0 outcome))
+
+noncomputable def lengthRecordImpl {ι σ : Type} {spec : OracleSpec ι}
+    {Ω : spec.Domain → Type}
+    (record : (input : spec.Domain) → σ → PMF (Ω input))
+    (response : (input : spec.Domain) → Ω input → spec.Range input)
+    (advance : (input : spec.Domain) → σ → Nat → Ω input → σ)
+    (active : spec.Domain → σ → Bool)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hle : accept ≤ 1) :
+    QueryImpl spec (StateT σ PMF) :=
+  fun input => StateT.mk fun state =>
+    if active input state then
+      (recordLengthBridge (record input state) accept hpos hle).map
+        (fun result => (response input result.2, advance input state result.1 result.2))
+    else
+      (record input state).map fun outcome => (response input outcome, advance input state 0 outcome)
+
+theorem proposalRecordImpl_project {ι α σ : Type} {spec : OracleSpec ι}
+    {Ω : spec.Domain → Type}
+    (record : (input : spec.Domain) → σ → PMF (Ω input))
+    (response : (input : spec.Domain) → Ω input → spec.Range input)
+    (advance : (input : spec.Domain) → σ → Nat → Ω input → σ)
+    (label : (input : spec.Domain) → Ω input → α)
+    (rejected : (input : spec.Domain) → σ → PMF α)
+    (active : spec.Domain → σ → Bool)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hle : accept ≤ 1)
+    (input : spec.Domain) (state : List α × σ) :
+    Prod.map id Prod.snd <$>
+      ((proposalRecordImpl record response advance label rejected active accept hpos hle) input).run state =
+    ((lengthRecordImpl record response advance active accept hpos hle) input).run state.2 := by
+  change PMF.map (Prod.map id Prod.snd) _ = _
+  simp only [proposalRecordImpl, lengthRecordImpl, StateT.run_mk]
+  by_cases hactive : active input state.2 = true
+  · simp only [hactive, if_true]
+    calc
+      _ = ((recordProposalBridge (record input state.2) (rejected input state.2) accept hpos hle).map
+          (fun result => (result.1.length + 1, result.2))).map
+            (fun result => (response input result.2, advance input state.2 result.1 result.2)) := by
+        rw [PMF.map_comp, PMF.map_comp]
+        rfl
+      _ = _ := by rw [recordProposalBridge_length_record]
+  · simp only [hactive, Bool.false_eq_true, if_false, PMF.map_comp]
+    rfl
+
+theorem simulateQ_proposalRecordImpl_project {ι α σ β : Type} {spec : OracleSpec ι}
+    {Ω : spec.Domain → Type}
+    (record : (input : spec.Domain) → σ → PMF (Ω input))
+    (response : (input : spec.Domain) → Ω input → spec.Range input)
+    (advance : (input : spec.Domain) → σ → Nat → Ω input → σ)
+    (label : (input : spec.Domain) → Ω input → α)
+    (rejected : (input : spec.Domain) → σ → PMF α)
+    (active : spec.Domain → σ → Bool)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hle : accept ≤ 1)
+    (computation : OracleComp spec β) (state : List α × σ) :
+    Prod.map id Prod.snd <$>
+      (simulateQ (proposalRecordImpl record response advance label rejected active accept hpos hle)
+        computation).run state =
+    (simulateQ (lengthRecordImpl record response advance active accept hpos hle)
+      computation).run state.2 :=
+  map_run_simulateQ_eq_of_query_map_eq _ _ Prod.snd
+    (proposalRecordImpl_project record response advance label rejected active accept hpos hle)
+    computation state
+
+theorem lengthRecordImpl_project {ι σ τ : Type} {spec : OracleSpec ι}
+    {Ω : spec.Domain → Type}
+    (record : (input : spec.Domain) → σ → PMF (Ω input))
+    (response : (input : spec.Domain) → Ω input → spec.Range input)
+    (advance : (input : spec.Domain) → σ → Nat → Ω input → σ)
+    (active : spec.Domain → σ → Bool)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hle : accept ≤ 1)
+    (base : QueryImpl spec (StateT τ PMF)) (project : σ → τ)
+    (next : (input : spec.Domain) → σ → Ω input → τ)
+    (hnext : ∀ input state length outcome, project (advance input state length outcome) = next input state outcome)
+    (hrecord : ∀ input state, (record input state).map
+      (fun outcome => (response input outcome, next input state outcome)) = (base input).run (project state))
+    (input : spec.Domain) (state : σ) :
+    Prod.map id project <$> ((lengthRecordImpl record response advance active accept hpos hle) input).run state =
+      (base input).run (project state) := by
+  change PMF.map (Prod.map id project) _ = _
+  simp only [lengthRecordImpl, StateT.run_mk]
+  by_cases hactive : active input state = true
+  · simp only [hactive, if_true, PMF.map_comp, Function.comp_def, Prod.map, id_eq, hnext]
+    calc
+      _ = ((recordLengthBridge (record input state) accept hpos hle).map Prod.snd).map
+          (fun outcome => (response input outcome, next input state outcome)) := by
+        rw [PMF.map_comp]
+        rfl
+      _ = _ := by rw [recordLengthBridge_record, hrecord]
+  · simpa only [hactive, Bool.false_eq_true, if_false, PMF.map_comp, Function.comp_def, Prod.map, id_eq, hnext]
+      using hrecord input state
+
+theorem simulateQ_lengthRecordImpl_project {ι σ τ β : Type} {spec : OracleSpec ι}
+    {Ω : spec.Domain → Type}
+    (record : (input : spec.Domain) → σ → PMF (Ω input))
+    (response : (input : spec.Domain) → Ω input → spec.Range input)
+    (advance : (input : spec.Domain) → σ → Nat → Ω input → σ)
+    (active : spec.Domain → σ → Bool)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hle : accept ≤ 1)
+    (base : QueryImpl spec (StateT τ PMF)) (project : σ → τ)
+    (next : (input : spec.Domain) → σ → Ω input → τ)
+    (hnext : ∀ input state length outcome, project (advance input state length outcome) = next input state outcome)
+    (hrecord : ∀ input state, (record input state).map
+      (fun outcome => (response input outcome, next input state outcome)) = (base input).run (project state))
+    (computation : OracleComp spec β) (state : σ) :
+    Prod.map id project <$>
+      (simulateQ (lengthRecordImpl record response advance active accept hpos hle) computation).run state =
+      (simulateQ base computation).run (project state) :=
+  map_run_simulateQ_eq_of_query_map_eq _ _ project
+    (lengthRecordImpl_project record response advance active accept hpos hle base project next hnext hrecord)
+    computation state
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/ProposalWordDistribution.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/ProposalWordDistribution.lean
new file mode 100644
index 000000000..2d78120b6
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/ProposalWordDistribution.lean
@@ -0,0 +1,125 @@
+import SphincsSecurity.Proof.Base.Prelude
+namespace SphincsSecurity.Concrete
+
+open ENNReal
+attribute [local instance] Classical.propDecidable
+
+theorem pmf_map_injective_apply {α β : Type*} (law : PMF α) (f : α → β)
+    (hinjective : Function.Injective f) (value : α) : (law.map f) (f value) = law value := by
+  rw [PMF.map_apply, tsum_eq_single value]
+  · simp only [↓reduceIte]
+  · intro other hne
+    exact if_neg (fun h => hne (hinjective h).symm)
+
+theorem pmf_map_apply_zero_of_not_image {α β : Type*} (law : PMF α) (f : α → β) (value : β)
+    (h : ∀ source, value ≠ f source) : (law.map f) value = 0 := by
+  letI : DecidableEq β := Classical.decEq β
+  rw [PMF.map_apply]
+  exact (tsum_congr (fun source => if_neg (h source))).trans tsum_zero
+
+noncomputable def independentProposalWord {α : Type*} (law : PMF α) : Nat → PMF (List α)
+  | 0 => pure []
+  | steps + 1 => law.bind fun next => (independentProposalWord law steps).map (next :: ·)
+
+theorem independentProposalWord_apply {α : Type*} (law : PMF α) (steps : Nat) (word : List α) :
+    independentProposalWord law steps word = if word.length = steps then (word.map law).prod else 0 := by
+  classical
+  letI : DecidableEq α := Classical.decEq α
+  induction steps generalizing word with
+  | zero => cases word <;> simp [independentProposalWord, PMF.pure_apply]
+  | succ steps ih =>
+      cases word with
+      | nil => simp [independentProposalWord, PMF.bind_apply, PMF.map_apply]
+      | cons next rest =>
+          rw [independentProposalWord, PMF.bind_apply]
+          have hm (head : α) : ((independentProposalWord law steps).map (head :: ·)) (next :: rest) =
+              if next = head then independentProposalWord law steps rest else 0 := by
+            by_cases h : next = head
+            · subst next
+              rw [if_pos rfl]
+              exact pmf_map_injective_apply _ _ (fun _ _ h => (List.cons.inj h).2) rest
+            · rw [if_neg h]
+              exact pmf_map_apply_zero_of_not_image _ _ _ (fun _ heq => h (List.cons.inj heq).1)
+          simp only [hm, tsum_ite_eq', mul_ite, mul_zero, ih, List.length_cons,
+            Nat.add_right_cancel_iff, List.map_cons, List.prod_cons]
+
+noncomputable def proposalFailureCount (accept : ENNReal) (hpos : accept ≠ 0) (hle : accept ≤ 1) : PMF Nat :=
+  ⟨fun count => accept * (1 - accept) ^ count, by
+    apply ENNReal.summable.hasSum_iff.mpr
+    have hdouble : 1 - (1 - accept) = accept :=
+      ENNReal.sub_eq_of_eq_add_rev' (by finiteness) (tsub_add_cancel_of_le hle).symm
+    rw [ENNReal.tsum_mul_left, ENNReal.tsum_geometric, hdouble,
+      ENNReal.mul_inv_cancel hpos (ne_top_of_le_ne_top (by finiteness) hle)]⟩
+
+theorem proposalFailureCount_apply (accept : ENNReal) (hpos : accept ≠ 0) (hle : accept ≤ 1) (count : Nat) :
+    proposalFailureCount accept hpos hle count = accept * (1 - accept) ^ count := rfl
+
+noncomputable def rejectedProposalWord {α : Type*} (law : PMF α)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hle : accept ≤ 1) : PMF (List α) :=
+  (proposalFailureCount accept hpos hle).bind (independentProposalWord law)
+
+theorem rejectedProposalWord_apply {α : Type*} (law : PMF α)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hle : accept ≤ 1) (word : List α) :
+    rejectedProposalWord law accept hpos hle word =
+      accept * (1 - accept) ^ word.length * (word.map law).prod := by
+  classical
+  simp only [rejectedProposalWord, PMF.bind_apply, independentProposalWord_apply, mul_ite, mul_zero,
+    tsum_ite_eq', proposalFailureCount_apply]
+
+theorem rejectedProposalWord_nil {α : Type*} (law : PMF α)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hle : accept ≤ 1) :
+    rejectedProposalWord law accept hpos hle [] = accept := by
+  simp only [rejectedProposalWord_apply, List.length_nil, pow_zero, List.map_nil, List.prod_nil, mul_one]
+
+theorem rejectedProposalWord_cons {α : Type*} (law : PMF α)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hle : accept ≤ 1) (next : α) (rest : List α) :
+    rejectedProposalWord law accept hpos hle (next :: rest) =
+      (1 - accept) * law next * rejectedProposalWord law accept hpos hle rest := by
+  simp only [rejectedProposalWord_apply, List.length_cons, pow_succ, List.map_cons, List.prod_cons]
+  ring
+
+noncomputable def recordProposalBridge {α Ω : Type*} (record : PMF Ω) (rejected : PMF α)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hle : accept ≤ 1) : PMF (List α × Ω) :=
+  record.bind fun outcome => (rejectedProposalWord rejected accept hpos hle).map (fun word => (word, outcome))
+
+theorem recordProposalBridge_apply {α Ω : Type*} (record : PMF Ω) (rejected : PMF α)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hle : accept ≤ 1) (word : List α) (outcome : Ω) :
+    recordProposalBridge record rejected accept hpos hle (word, outcome) =
+      record outcome * rejectedProposalWord rejected accept hpos hle word := by
+  classical
+  letI : DecidableEq Ω := Classical.decEq Ω
+  rw [recordProposalBridge, PMF.bind_apply]
+  have hm (value : Ω) :
+      ((rejectedProposalWord rejected accept hpos hle).map (fun word => (word, value))) (word, outcome) =
+        if outcome = value then rejectedProposalWord rejected accept hpos hle word else 0 := by
+    by_cases h : outcome = value
+    · subst outcome
+      rw [if_pos rfl]
+      exact pmf_map_injective_apply _ _ (fun _ _ h => (Prod.mk.inj h).1) word
+    · rw [if_neg h]
+      exact pmf_map_apply_zero_of_not_image _ _ _ (fun _ heq => h (Prod.mk.inj heq).2)
+  simp only [hm, mul_ite, mul_zero, tsum_ite_eq']
+
+theorem recordProposalBridge_record {α Ω : Type*} (record : PMF Ω) (rejected : PMF α)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hle : accept ≤ 1) :
+    (recordProposalBridge record rejected accept hpos hle).map Prod.snd = record := by
+  unfold recordProposalBridge
+  rw [PMF.map_bind]
+  simp only [PMF.map_comp, Function.comp_def]
+  change (record.bind fun outcome =>
+    (rejectedProposalWord rejected accept hpos hle).map (Function.const (List α) outcome)) = record
+  simp only [PMF.map_const, PMF.bind_pure]
+
+theorem recordProposalBridge_nil {α Ω : Type*} (record : PMF Ω) (rejected : PMF α)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hle : accept ≤ 1) (outcome : Ω) :
+    recordProposalBridge record rejected accept hpos hle ([], outcome) = accept * record outcome := by
+  rw [recordProposalBridge_apply, rejectedProposalWord_nil, mul_comm]
+
+theorem recordProposalBridge_cons {α Ω : Type*} (record : PMF Ω) (rejected : PMF α)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hle : accept ≤ 1) (next : α) (rest : List α) (outcome : Ω) :
+    recordProposalBridge record rejected accept hpos hle (next :: rest, outcome) =
+      (1 - accept) * rejected next * recordProposalBridge record rejected accept hpos hle (rest, outcome) := by
+  rw [recordProposalBridge_apply, recordProposalBridge_apply, rejectedProposalWord_cons]
+  ring
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/PublicSigningRecord.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/PublicSigningRecord.lean
new file mode 100644
index 000000000..a66e68eea
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/PublicSigningRecord.lean
@@ -0,0 +1,85 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.FrontierSigningOracleCongruence
+import SphincsSecurity.Proof.Hypertree.PublicGraphSigner
+import SphincsSecurity.Proof.Residual.RetainedObservation
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] instFintypePosition boundaryEval publicDigestLoop
+
+abbrev PublicSigningRecord := (Option PublicSigningPlan × Option FewTimeView) × SigningBoundaryTrace
+
+def completePublicSigningRecord (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (record : PublicSigningRecord) : (Option Signature × Option FewTimeView) × SigningBoundaryTrace :=
+  match record.1.2 with
+  | none => ((none, none), record.2)
+  | some view => ((record.1.1.map (fun plan => plan.finish (fun tree => ftsSecret view.1 tree (view.2 tree))), some view), record.2)
+
+noncomputable def publicSigningRecord (parameter : PublicParameter) (root : Digest) (outside : QueryImpl HashSpec Id)
+    (known : Labels) (words : OtsReferenceWords) (selections : ReferenceFamily) (message : Message) :
+    ProbComp PublicSigningRecord := do
+  let selected ← fixedBoundaryRun parameter outside (publicDigestLoop parameter root message digestAttemptLimit)
+  match selected.1 with
+  | none => pure ((none, none), selected.2)
+  | some (randomness, index, leaves) =>
+      let plan := publicSignPlan known words selections randomness index leaves
+      pure ((plan.1, some (selectedFewTimeView index leaves)), selected.2 * (FreeMonoid.of none) ^ plan.2)
+
+theorem boundaryEval_publicSignAttempt_eq_of_message (parameter : PublicParameter) (root : Digest) (message : Message)
+    (f g : QueryImpl HashSpec Id) (randomness : Randomness)
+    (hmessage : f (tweakableHashInput parameter .message (messageDigestPayload root message randomness)) =
+      g (tweakableHashInput parameter .message (messageDigestPayload root message randomness))) :
+    boundaryEval parameter f (publicSignAttempt parameter root message randomness) =
+      boundaryEval parameter g (publicSignAttempt parameter root message randomness) := by
+  simp [publicSignAttempt, messageDigest, oracleHash, boundaryEval, QueryImpl.withTrace_apply, hmessage]
+
+theorem fixedBoundaryRun_publicDigestLoop_eq_of_message (parameter : PublicParameter) (root : Digest) (message : Message)
+    (f g : QueryImpl HashSpec Id)
+    (hmessage : ∀ randomness, f (tweakableHashInput parameter .message (messageDigestPayload root message randomness)) =
+      g (tweakableHashInput parameter .message (messageDigestPayload root message randomness))) (attempts : Nat) :
+    fixedBoundaryRun parameter f (publicDigestLoop parameter root message attempts) =
+      fixedBoundaryRun parameter g (publicDigestLoop parameter root message attempts) := by
+  induction attempts with
+  | zero => simp only [publicDigestLoop, fixedBoundaryRun_pure]
+  | succ attempts ih =>
+      rw [publicDigestLoop]
+      apply fixedBoundaryRun_bind_congr
+      · exact fixedBoundaryRun_lift_prob_eq parameter f g sampleRandomness
+      · intro randomness
+        apply fixedBoundaryRun_bind_congr
+        · rw [fixedBoundaryRun_lift_hash, fixedBoundaryRun_lift_hash,
+            boundaryEval_publicSignAttempt_eq_of_message parameter root message f g randomness (hmessage randomness)]
+        · intro attempt
+          cases attempt with
+          | none => exact ih
+          | some selected => rfl
+
+theorem frontierSigningRecord_eq_public (key : SecretKey) (root : Digest) (f g : QueryImpl HashSpec Id)
+    (words : OtsReferenceWords) (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels)
+    (hagrees : PublicAgreement words disclosed known
+      (CanonicalCoordinate.value key.otsSecret key.ftsSecret (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f)))
+    (message : Message)
+    (hmessage : ∀ randomness, f (tweakableHashInput key.parameter .message (messageDigestPayload root message randomness)) =
+      g (tweakableHashInput key.parameter .message (messageDigestPayload root message randomness))) :
+    frontierSigningRecord key.parameter root f key.ftsSecret words
+        (canonicalGraphFrontier key.otsSecret (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f) words) message =
+      completePublicSigningRecord key.ftsSecret <$>
+        publicSigningRecord key.parameter root g known words (referenceTableSelection key f) message := by
+  rw [frontierSigningRecord, publicSigningRecord, map_bind,
+    fixedBoundaryRun_publicDigestLoop_eq_of_message key.parameter root message f g hmessage]
+  apply bind_congr
+  rintro ⟨selected, trace⟩
+  cases selected with
+  | none => rfl
+  | some selected =>
+      obtain ⟨randomness, index, leaves⟩ := selected
+      dsimp only
+      rw [map_pure, frontierSignAfterDigest_eq_publicPlan key f words disclosed known hagrees]
+      rfl
+
+theorem completePublicSigningRecord_trace (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (record : PublicSigningRecord) :
+    (completePublicSigningRecord ftsSecret record).2 = record.2 := by
+  cases hview : record.1.2 <;> simp only [completePublicSigningRecord, hview]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/RawProposalMomentBound.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/RawProposalMomentBound.lean
new file mode 100644
index 000000000..5db7d68dc
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/RawProposalMomentBound.lean
@@ -0,0 +1,143 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.RawSigningMomentBound
+import SphincsSecurity.Proof.Fts.MessageDeficitConcentration
+
+/-! ## InitialTargetShape -/
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem TargetShapeValid.empty (remaining : Finset FtsTree) : TargetShapeValid ∅ remaining := by
+  constructor <;> intro group hgroup <;> exact (Finset.notMem_empty group hgroup).elim
+
+end SphincsSecurity.Concrete
+
+/-! ## NearUniformRawStep -/
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+
+noncomputable def nearUniformDigestReuseWeight : ENNReal :=
+  (1025 / 1024 : ENNReal) * ((2 ^ 118 : Nat) : ENNReal)⁻¹
+
+theorem exactDigestReuseWeight_le_near_uniform_of_clean_cache (key : SecretKey) (cache : QueryCache HashSpec)
+    (cap : Nat) (hcap : cap ≤ 2 ^ 127) (hcache : QueryCache.enncard cache ≤ cap)
+    (hclean : ¬ MessageDeficitExceptional key cache) (message : Message) :
+    exactDigestReuseWeight key message cache ≤ nearUniformDigestReuseWeight :=
+  exactDigestReuseWeight_le_near_uniform_of_deficit key message cache cap hcap hcache
+    (le_of_not_gt (fun h => hclean ⟨message, h⟩))
+
+end SphincsSecurity.Concrete
+
+namespace SphincsSecurity.Concrete
+
+open ENNReal
+
+theorem reuseRawEnvelope_le_binomialAverage (key : SecretKey) (reuse rate : ENNReal)
+    (hrate : rate ≤ 1) (queries signatures bound : Nat) (state : CoverLogState)
+    (remaining : Finset FtsTree) (hdegree : remaining.card ≤ bound)
+    (hprob : ∀ index : Index,
+      (Fintype.card Index : ENNReal)⁻¹ + reuse *
+        (cachedIndexMultiplicity key.parameter state.1 index +
+          (queries : ENNReal) * ((2 ^ 36 : Nat) : ENNReal)⁻¹ + bound + signatures) ≤ rate) :
+    reuseRawEnvelope key reuse queries signatures state ∅ remaining ≤
+      ∑ index : Index, binomialAverage rate signatures (fun count =>
+        (((signingSlotsAtIndex (observedOptionalSigningViews
+          (FtsProbeSimulation.messageAnswers key.parameter state.1) key.root state.2) index).card : ENNReal) + count) ^
+          remaining.card) := by
+  apply (reuseRawEnvelope_query_shift_le key reuse queries signatures bound state ∅ remaining
+    (TargetShapeValid.empty _) (by simpa only [Finset.card_empty, Nat.zero_add] using hdegree)).trans
+  apply Finset.sum_le_sum
+  intro index _
+  exact targetIndexSigning_iterate_power_le_binomialAverage hrate signatures (hprob index) _ remaining.card
+
+noncomputable def targetProposalOverhead : ENNReal := 1537 / 1024
+
+noncomputable def targetProposalIndexRate : ENNReal :=
+  targetProposalOverhead * (Fintype.card Index : ENNReal)⁻¹
+
+theorem targetProposalIndexRate_le_one : targetProposalIndexRate ≤ 1 := by
+  unfold targetProposalIndexRate targetProposalOverhead
+  norm_num only [Index, totalHeight, Fintype.card_fin]
+  apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp
+  norm_num [ENNReal.toReal_mul, ENNReal.toReal_div, ENNReal.toReal_inv, Index, totalHeight]
+
+theorem targetProposalRate_of_cache_bound (cache : ENNReal) (spent queries signatures bound : Nat)
+    (hqueries : spent + queries ≤ 2 ^ 127) (hsignatures : signatures ≤ signatureLimit) (hbound : bound ≤ 14)
+    (hcache : cache ≤ (spent : ENNReal) * ((2 ^ 36 : Nat) : ENNReal)⁻¹ + ((2 ^ 80 : Nat) : ENNReal)) :
+    (Fintype.card Index : ENNReal)⁻¹ + nearUniformDigestReuseWeight *
+      (cache + (queries : ENNReal) * ((2 ^ 36 : Nat) : ENNReal)⁻¹ + bound + signatures) ≤
+        targetProposalIndexRate := by
+  have hsize : cache + (queries : ENNReal) * ((2 ^ 36 : Nat) : ENNReal)⁻¹ + bound + signatures ≤
+      ((2 ^ 127 : Nat) : ENNReal) * ((2 ^ 36 : Nat) : ENNReal)⁻¹ +
+        ((2 ^ 80 : Nat) : ENNReal) + 14 + signatureLimit := by
+    calc
+      _ ≤ (spent : ENNReal) * ((2 ^ 36 : Nat) : ENNReal)⁻¹ + ((2 ^ 80 : Nat) : ENNReal) +
+          (queries : ENNReal) * ((2 ^ 36 : Nat) : ENNReal)⁻¹ + bound + signatures := by
+        gcongr
+      _ = ((spent + queries : Nat) : ENNReal) * ((2 ^ 36 : Nat) : ENNReal)⁻¹ +
+          ((2 ^ 80 : Nat) : ENNReal) + bound + signatures := by
+        push_cast
+        ring
+      _ ≤ _ := by
+        exact add_le_add
+          (add_le_add (add_le_add (mul_le_mul' (Nat.cast_le.mpr hqueries) le_rfl) le_rfl)
+            (by exact_mod_cast hbound)) (Nat.cast_le.mpr hsignatures)
+  apply (add_le_add le_rfl (mul_le_mul' le_rfl hsize)).trans
+  unfold nearUniformDigestReuseWeight targetProposalIndexRate targetProposalOverhead
+  norm_num only [Index, totalHeight, Fintype.card_fin, signatureLimit]
+  apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp
+  simp (disch := finiteness) only [ENNReal.toReal_add, ENNReal.toReal_mul, ENNReal.toReal_div, ENNReal.toReal_inv]
+  norm_num
+
+theorem reuseRawEnvelope_le_proposalIndexAverage (key : SecretKey)
+    (spent queries signatures bound : Nat) (state : CoverLogState) (remaining : Finset FtsTree)
+    (hqueries : spent + queries ≤ 2 ^ 127) (hsignatures : signatures ≤ signatureLimit)
+    (hdegree : remaining.card ≤ bound) (hbound : bound ≤ 14)
+    (hcache : ∀ index : Index, cachedIndexMultiplicity key.parameter state.1 index ≤
+      (spent : ENNReal) * ((2 ^ 36 : Nat) : ENNReal)⁻¹ + ((2 ^ 80 : Nat) : ENNReal)) :
+    reuseRawEnvelope key nearUniformDigestReuseWeight queries signatures state ∅ remaining ≤
+      ∑ index : Index, binomialAverage targetProposalIndexRate signatures (fun count =>
+        (((signingSlotsAtIndex (observedOptionalSigningViews
+          (FtsProbeSimulation.messageAnswers key.parameter state.1) key.root state.2) index).card : ENNReal) + count) ^
+          remaining.card) :=
+  reuseRawEnvelope_le_binomialAverage key nearUniformDigestReuseWeight targetProposalIndexRate
+    targetProposalIndexRate_le_one queries signatures bound state remaining hdegree
+    (fun index => targetProposalRate_of_cache_bound _ spent queries signatures bound hqueries hsignatures hbound (hcache index))
+
+theorem proposalIndexAverage_le_uniformAverage (signatures proposals degree : Nat)
+    {signings consumed : ENNReal} (hcounts : signings ≤ consumed)
+    (hroom : targetProposalOverhead * signatures + degree ≤ ((proposals + 1 : Nat) : ENNReal)) :
+    binomialAverage targetProposalIndexRate signatures (fun count => (signings + count) ^ degree) ≤
+      binomialAverage (Fintype.card Index : ENNReal)⁻¹ proposals (fun count => (consumed + count) ^ degree) := by
+  apply binomialAverage_shifted_power_le_of_room targetProposalIndexRate_le_one
+    (by norm_num [Index, totalHeight]) hcounts signatures proposals degree (mass := targetProposalOverhead * signatures)
+  · unfold targetProposalIndexRate
+    exact le_of_eq (by ring)
+  · exact hroom
+
+theorem reuseRawEnvelope_le_uniformProposalAverage (key : SecretKey)
+    (spent queries signatures bound proposals : Nat) (state : CoverLogState) (remaining : Finset FtsTree)
+    (consumed : Index → Nat) (hqueries : spent + queries ≤ 2 ^ 127) (hsignatures : signatures ≤ signatureLimit)
+    (hdegree : remaining.card ≤ bound) (hbound : bound ≤ 14)
+    (hcache : ∀ index : Index, cachedIndexMultiplicity key.parameter state.1 index ≤
+      (spent : ENNReal) * ((2 ^ 36 : Nat) : ENNReal)⁻¹ + ((2 ^ 80 : Nat) : ENNReal))
+    (hcounts : ∀ index : Index,
+      (signingSlotsAtIndex (observedOptionalSigningViews
+        (FtsProbeSimulation.messageAnswers key.parameter state.1) key.root state.2) index).card ≤ consumed index)
+    (hroom : targetProposalOverhead * signatures + remaining.card ≤ ((proposals + 1 : Nat) : ENNReal)) :
+    reuseRawEnvelope key nearUniformDigestReuseWeight queries signatures state ∅ remaining ≤
+      ∑ index : Index, binomialAverage (Fintype.card Index : ENNReal)⁻¹ proposals
+        (fun count => ((consumed index : ENNReal) + count) ^ remaining.card) := by
+  apply (reuseRawEnvelope_le_proposalIndexAverage key spent queries signatures bound state remaining
+    hqueries hsignatures hdegree hbound hcache).trans
+  apply Finset.sum_le_sum
+  intro index _
+  exact proposalIndexAverage_le_uniformAverage signatures proposals remaining.card
+    (Nat.cast_le.mpr (hcounts index)) hroom
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/RawSigningMomentBound.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/RawSigningMomentBound.lean
new file mode 100644
index 000000000..8ee1f2bee
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/RawSigningMomentBound.lean
@@ -0,0 +1,193 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Scheme.RawQueryMomentBound
+namespace SphincsSecurity.Concrete
+
+open ENNReal
+
+theorem targetIndexSigning_add (uniform reuse : ENNReal) (first second : TargetIndexVector) :
+    targetIndexSigning uniform reuse (fun p d => first p d + second p d) =
+      fun p d => targetIndexSigning uniform reuse first p d + targetIndexSigning uniform reuse second p d := by
+  funext power degree
+  simp only [targetIndexSigning, targetIndexCacheLower, targetIndexTreeLower, targetIndexReuseStep,
+    mul_add, Finset.sum_add_distrib]
+  ring
+
+theorem targetIndexSigning_mul (uniform reuse scalar : ENNReal) (moments : TargetIndexVector) :
+    targetIndexSigning uniform reuse (fun p d => scalar * moments p d) =
+      fun p d => scalar * targetIndexSigning uniform reuse moments p d := by
+  have hcache (values : TargetIndexVector) (p d : Nat) :
+      targetIndexCacheLower (fun p d => scalar * values p d) p d =
+        scalar * targetIndexCacheLower values p d := by
+    simp only [targetIndexCacheLower, Finset.mul_sum]
+    apply Finset.sum_congr rfl
+    intro lower _
+    ring
+  have htree (values : TargetIndexVector) : targetIndexTreeLower (fun p d => scalar * values p d) =
+      fun p d => scalar * targetIndexTreeLower values p d := by
+    funext p d
+    simp only [targetIndexTreeLower, Finset.mul_sum]
+    apply Finset.sum_congr rfl
+    intro lower _
+    ring
+  funext power degree
+  simp only [targetIndexSigning, hcache, htree, targetIndexReuseStep]
+  ring
+
+theorem targetIndexSigning_iterate_add (uniform reuse : ENNReal) (steps : Nat) (first second : TargetIndexVector) :
+    (targetIndexSigning uniform reuse)^[steps] (fun p d => first p d + second p d) =
+      fun p d => (targetIndexSigning uniform reuse)^[steps] first p d +
+        (targetIndexSigning uniform reuse)^[steps] second p d := by
+  induction steps with
+  | zero => rfl
+  | succ steps ih => simp only [Function.iterate_succ_apply', ih, targetIndexSigning_add]
+
+theorem targetIndexSigning_iterate_mul (uniform reuse scalar : ENNReal) (steps : Nat) (moments : TargetIndexVector) :
+    (targetIndexSigning uniform reuse)^[steps] (fun p d => scalar * moments p d) =
+      fun p d => scalar * (targetIndexSigning uniform reuse)^[steps] moments p d := by
+  induction steps with
+  | zero => rfl
+  | succ steps ih => simp only [Function.iterate_succ_apply', ih, targetIndexSigning_mul]
+
+theorem indexPowerVector_signing_succ (cache signings : ENNReal) :
+    indexPowerVector cache (signings + 1) =
+      fun p d => indexPowerVector cache signings p d + targetIndexTreeLower (indexPowerVector cache signings) p d := by
+  funext power degree
+  simp only [indexPowerVector, ennreal_add_one_pow, mul_add, Finset.mul_sum, targetIndexTreeLower]
+  congr 1
+  apply Finset.sum_congr rfl
+  intro lower _
+  ring
+
+theorem indexPowerVector_diagonal_succ (cache signings : ENNReal) (power degree : Nat) :
+    indexPowerVector (cache + 1) (signings + 1) power degree =
+      indexPowerVector cache signings power degree + targetIndexCacheLower (indexPowerVector cache signings) power degree +
+        targetIndexTreeLower (indexPowerVector cache signings) power degree +
+        targetIndexCacheLower (targetIndexTreeLower (indexPowerVector cache signings)) power degree := by
+  rw [indexPowerVector_cache_succ, indexPowerVector_signing_succ]
+  simp only [targetIndexCacheLower, mul_add, Finset.sum_add_distrib]
+  ring
+
+theorem targetIndexReuseStep_power (cache signings : ENNReal) (power degree : Nat) :
+    targetIndexReuseStep (indexPowerVector cache signings) power degree =
+      cache * targetIndexTreeLower (indexPowerVector cache signings) power degree := by
+  simp only [targetIndexReuseStep, targetIndexTreeLower, indexPowerVector, pow_succ, Finset.mul_sum]
+  apply Finset.sum_congr rfl
+  intro lower _
+  ring
+
+theorem targetIndexSigning_power {uniform reuse cache : ENNReal}
+    (hprob : uniform + reuse * cache ≤ 1) (signings : ENNReal) (power degree : Nat) :
+    targetIndexSigning uniform reuse (indexPowerVector cache signings) power degree =
+      (1 - (uniform + reuse * cache)) * indexPowerVector cache signings power degree +
+        uniform * indexPowerVector (cache + 1) (signings + 1) power degree +
+        reuse * cache * indexPowerVector cache (signings + 1) power degree := by
+  rw [indexPowerVector_diagonal_succ, indexPowerVector_signing_succ]
+  simp only [targetIndexSigning, targetIndexReuseStep_power]
+  have hsum : 1 - (uniform + reuse * cache) + (uniform + reuse * cache) = 1 :=
+    tsub_add_cancel_of_le hprob
+  calc
+    _ = (1 - (uniform + reuse * cache) + (uniform + reuse * cache)) *
+        indexPowerVector cache signings power degree + uniform *
+          (targetIndexCacheLower (indexPowerVector cache signings) power degree +
+            targetIndexTreeLower (indexPowerVector cache signings) power degree +
+            targetIndexCacheLower (targetIndexTreeLower (indexPowerVector cache signings)) power degree) +
+          reuse * cache * targetIndexTreeLower (indexPowerVector cache signings) power degree := by
+      rw [hsum]
+      ring
+    _ = _ := by ring
+
+noncomputable def indexSigningAverage (uniform reuse : ENNReal) :
+    Nat → (ENNReal → ENNReal → ENNReal) → ENNReal → ENNReal → ENNReal
+  | 0, f, cache, signings => f cache signings
+  | steps + 1, f, cache, signings =>
+      (1 - (uniform + reuse * cache)) * indexSigningAverage uniform reuse steps f cache signings +
+        uniform * indexSigningAverage uniform reuse steps f (cache + 1) (signings + 1) +
+        reuse * cache * indexSigningAverage uniform reuse steps f cache (signings + 1)
+
+theorem targetIndexSigning_iterate_power {uniform reuse cache : ENNReal}
+    (steps : Nat) (hprob : uniform + reuse * (cache + steps) ≤ 1)
+    (signings : ENNReal) (power degree : Nat) :
+    (targetIndexSigning uniform reuse)^[steps] (indexPowerVector cache signings) power degree =
+      indexSigningAverage uniform reuse steps (fun c s => indexPowerVector c s power degree) cache signings := by
+  induction steps generalizing cache signings power degree with
+  | zero => rfl
+  | succ steps ih =>
+      have hbase : uniform + reuse * cache ≤ 1 :=
+        (add_le_add le_rfl (mul_le_mul' le_rfl le_self_add)).trans hprob
+      have hstay : uniform + reuse * (cache + steps) ≤ 1 := by
+        apply le_trans _ hprob
+        gcongr
+        exact Nat.le_succ steps
+      have hnext : uniform + reuse * (cache + 1 + steps) ≤ 1 := by
+        simpa only [Nat.cast_add, Nat.cast_one, add_assoc, add_comm, add_left_comm] using hprob
+      have hfun : targetIndexSigning uniform reuse (indexPowerVector cache signings) =
+          fun p d => (1 - (uniform + reuse * cache)) * indexPowerVector cache signings p d +
+            uniform * indexPowerVector (cache + 1) (signings + 1) p d +
+            reuse * cache * indexPowerVector cache (signings + 1) p d := by
+        funext p d
+        exact targetIndexSigning_power hbase signings p d
+      rw [Function.iterate_succ_apply, hfun]
+      simp only [targetIndexSigning_iterate_add, targetIndexSigning_iterate_mul]
+      rw [ih hstay, ih hnext, ih hstay]
+      rfl
+
+theorem bernoulli_mix_rate_mono {rate nextRate first second : ENNReal}
+    (hrate : rate ≤ nextRate) (hnext : nextRate ≤ 1) (hvalue : first ≤ second) :
+    (1 - rate) * first + rate * second ≤ (1 - nextRate) * first + nextRate * second := by
+  have hsum : first + (second - first) = second := add_tsub_cancel_of_le hvalue
+  calc
+    _ = first + rate * (second - first) := by
+      conv_lhs => rhs; rw [← hsum]
+      exact bernoulli_mix_increment (hrate.trans hnext) _ _
+    _ ≤ first + nextRate * (second - first) := add_le_add le_rfl (mul_le_mul' hrate le_rfl)
+    _ = _ := by
+      rw [← bernoulli_mix_increment hnext, hsum]
+
+theorem indexSigningAverage_le_binomialAverage {uniform reuse rate cache : ENNReal}
+    (hrate : rate ≤ 1) (steps : Nat) (hprob : uniform + reuse * (cache + steps) ≤ rate)
+    (f : ENNReal → ENNReal) (hmono : Monotone f) (signings : ENNReal) :
+    indexSigningAverage uniform reuse steps (fun _ s => f s) cache signings ≤
+      binomialAverage rate steps (fun count => f (signings + count)) := by
+  induction steps generalizing cache signings with
+  | zero => simp only [indexSigningAverage, binomialAverage_zero, Nat.cast_zero, add_zero, le_refl]
+  | succ steps ih =>
+      have hbase : uniform + reuse * cache ≤ rate :=
+        (add_le_add le_rfl (mul_le_mul' le_rfl le_self_add)).trans hprob
+      have hstay : uniform + reuse * (cache + steps) ≤ rate := by
+        apply le_trans _ hprob
+        gcongr
+        exact Nat.le_succ steps
+      have hnext : uniform + reuse * (cache + 1 + steps) ≤ rate := by
+        simpa only [Nat.cast_add, Nat.cast_one, add_assoc, add_comm, add_left_comm] using hprob
+      have hvalue : binomialAverage rate steps (fun count => f (signings + count)) ≤
+          binomialAverage rate steps (fun count => f (signings + 1 + count)) :=
+        binomialAverage_mono rate steps (fun _ => hmono (add_le_add le_self_add le_rfl))
+      calc
+        _ ≤ (1 - (uniform + reuse * cache)) *
+              binomialAverage rate steps (fun count => f (signings + count)) +
+            uniform * binomialAverage rate steps (fun count => f (signings + 1 + count)) +
+            reuse * cache * binomialAverage rate steps (fun count => f (signings + 1 + count)) :=
+          add_le_add (add_le_add (mul_le_mul' le_rfl (ih hstay signings))
+            (mul_le_mul' le_rfl (ih hnext (signings + 1))))
+            (mul_le_mul' le_rfl (ih hstay (signings + 1)))
+        _ = (1 - (uniform + reuse * cache)) *
+              binomialAverage rate steps (fun count => f (signings + count)) +
+            (uniform + reuse * cache) *
+              binomialAverage rate steps (fun count => f (signings + 1 + count)) := by ring
+        _ ≤ (1 - rate) * binomialAverage rate steps (fun count => f (signings + count)) +
+            rate * binomialAverage rate steps (fun count => f (signings + 1 + count)) :=
+          bernoulli_mix_rate_mono hbase hrate hvalue
+        _ = _ := by
+          simp only [binomialAverage_succ, Nat.cast_add, Nat.cast_one, add_comm, add_left_comm]
+
+theorem targetIndexSigning_iterate_power_le_binomialAverage {uniform reuse rate cache : ENNReal}
+    (hrate : rate ≤ 1) (steps : Nat) (hprob : uniform + reuse * (cache + steps) ≤ rate)
+    (signings : ENNReal) (degree : Nat) :
+    (targetIndexSigning uniform reuse)^[steps] (indexPowerVector cache signings) 0 degree ≤
+      binomialAverage rate steps (fun count => (signings + count) ^ degree) := by
+  rw [targetIndexSigning_iterate_power steps (hprob.trans hrate)]
+  simp only [indexPowerVector, pow_zero, one_mul]
+  exact indexSigningAverage_le_binomialAverage hrate steps hprob (fun s => s ^ degree)
+    (fun _ _ h => pow_le_pow_left' h degree) signings
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/ReferenceFtsCoverage.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/ReferenceFtsCoverage.lean
new file mode 100644
index 000000000..7ca781ed0
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/ReferenceFtsCoverage.lean
@@ -0,0 +1,110 @@
+import SphincsSecurity.Proof.Reference.ReferenceVerifierInstantiation
+import SphincsSecurity.Proof.Residual.RetainedResidualSigningHistory
+import SphincsSecurity.Proof.Fts.BankedTargetEnvelope
+namespace SphincsSecurity.Concrete.ReferenceFtsCoverage
+
+open _root_.OracleComp OracleSpec OtsContactTrace
+open RetainedResidual (signingInput signingView)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] signAfterDigest canonicalGraphInputs canonicalEncodingInputs
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def transcriptCache (f : QueryImpl HashSpec Id) (boundary : SigningBoundaryTrace) (trace : Trace) : QueryCache HashSpec :=
+  recordedCache f (FreeMonoid.ofList boundary.messageCalls * trace)
+
+def CoveredByLog (key : SecretKey) (f : QueryImpl HashSpec Id) (log : QueryLog SigningSpec) (target : FewTimeView) (tree : FtsTree) : Prop :=
+  ∃ message signature, (⟨message, some signature⟩ : SigningEntry) ∈ log ∧
+    (signingView key f message signature).1 = target.1 ∧ (signingView key f message signature).2 tree = target.2 tree
+
+theorem cache_trace (f : QueryImpl HashSpec Id) (boundary : SigningBoundaryTrace) (trace : Trace) (input : HashInput)
+    (h : (input, f input) ∈ trace.toList) : transcriptCache f boundary trace input = some (f input) := by
+  apply if_pos
+  exact List.mem_append_right _ h
+
+theorem cache_signing {key : SecretKey} {f : QueryImpl HashSpec Id} {message : Message} {signature : Signature}
+    {boundary : SigningBoundaryTrace} (h : ReferenceSigningWitness.SignatureOrigin key f message signature boundary) (trace : Trace) :
+    transcriptCache f boundary trace (signingInput key message signature) = some (f (signingInput key message signature)) := by
+  apply if_pos
+  exact List.mem_append_left _ h.1
+
+theorem covered_witness (key : SecretKey) (f : QueryImpl HashSpec Id) (log : QueryLog SigningSpec)
+    (boundary : SigningBoundaryTrace) (trace : Trace) (forgery : Forgery)
+    (horigin : ∀ message signature, (⟨message, some signature⟩ : SigningEntry) ∈ log →
+      ReferenceSigningWitness.SignatureOrigin key f message signature boundary)
+    (hnew : ∀ message signature, (⟨message, some signature⟩ : SigningEntry) ∈ log →
+      messageDigestPayload key.root message signature.randomness ≠ messageDigestPayload key.root forgery.message forgery.signature.randomness)
+    (target : FewTimeView) (tree : FtsTree) (hcovered : CoveredByLog key f log target tree) :
+    ∃ slot view, fixedSigningViews key.parameter (transcriptCache f boundary trace) key.root log
+      (signingInput key forgery.message forgery.signature) slot = some view ∧ view.1 = target.1 ∧ view.2 tree = target.2 tree := by
+  obtain ⟨message, signature, hentry, hi, hl⟩ := hcovered
+  obtain ⟨slot, hslot⟩ := List.mem_iff_get.mp hentry
+  refine ⟨slot, signingView key f message signature, ?_, hi, hl⟩
+  change eligibleSigningView? _ _ _ (log.get slot) = _
+  rw [hslot]
+  simp only [eligibleSigningView?, signingInput, payloadOf_tweakableHashInput, Option.bind_eq_bind', Option.bind_some,
+    if_neg (hnew message signature hentry), observedSigningView?, FtsProbeSimulation.messageAnswers]
+  change (transcriptCache f boundary trace (signingInput key message signature) >>= fun answer => pure (hashOutputFewTimeView answer)) = _
+  rw [cache_signing (horigin message signature hentry)]
+  rfl
+
+theorem certificate_of_covered (key : SecretKey) (f : QueryImpl HashSpec Id) (log : QueryLog SigningSpec)
+    (boundary : SigningBoundaryTrace) (trace : Trace) (forgery : Forgery) (required : Finset FtsTree)
+    (horigin : ∀ message signature, (⟨message, some signature⟩ : SigningEntry) ∈ log →
+      ReferenceSigningWitness.SignatureOrigin key f message signature boundary)
+    (hnew : ∀ message signature, (⟨message, some signature⟩ : SigningEntry) ∈ log →
+      messageDigestPayload key.root message signature.randomness ≠ messageDigestPayload key.root forgery.message forgery.signature.randomness)
+    (hrun : ContainsRun f trace (messageDigest key.parameter key.root forgery.message forgery.signature.randomness))
+    (hadmissible : Admissible (truncateMessageDigest (f (signingInput key forgery.message forgery.signature))))
+    (hcovered : ∀ tree ∈ required, CoveredByLog key f log (signingView key f forgery.message forgery.signature) tree) :
+    TargetCertificateAt key required (transcriptCache f boundary trace, log) (signingInput key forgery.message forgery.signature) := by
+  have hrow : (signingInput key forgery.message forgery.signature, f (signingInput key forgery.message forgery.signature)) ∈ trace.toList := by
+    apply hrun
+    change signingInput key forgery.message forgery.signature ∈ [signingInput key forgery.message forgery.signature]
+    exact List.mem_singleton_self _
+  refine ⟨f (signingInput key forgery.message forgery.signature), cache_trace f boundary trace _ hrow, ?_, hadmissible, ?_⟩
+  · exact ⟨messageDigestPayload key.root forgery.message forgery.signature.randomness, rfl⟩
+  · intro tree ht
+    exact (targetTreeMatchCount_pos_iff _ _ tree).mpr
+      (covered_witness key f log boundary trace forgery horigin hnew _ tree (hcovered tree ht))
+
+def NearGuess (key : SecretKey) (f : QueryImpl HashSpec Id) (log : QueryLog SigningSpec)
+    (boundary : SigningBoundaryTrace) (trace : Trace) (forgery : Forgery) : Prop :=
+  let target := signingView key f forgery.message forgery.signature
+  ∃ omitted : FtsTree,
+    TargetCertificateAt key (Finset.univ.erase omitted) (transcriptCache f boundary trace, log) (signingInput key forgery.message forgery.signature) ∧
+    ¬CoveredByLog key f log target omitted ∧ FtsVerifierWitness.TrueSecretQuery f key target.1 omitted (target.2 omitted) trace
+
+def TwoGuesses (key : SecretKey) (f : QueryImpl HashSpec Id) (log : QueryLog SigningSpec) (trace : Trace) (forgery : Forgery) : Prop :=
+  let target := signingView key f forgery.message forgery.signature
+  ∃ first second : FtsTree, first ≠ second ∧
+    ¬CoveredByLog key f log target first ∧ FtsVerifierWitness.TrueSecretQuery f key target.1 first (target.2 first) trace ∧
+    ¬CoveredByLog key f log target second ∧ FtsVerifierWitness.TrueSecretQuery f key target.1 second (target.2 second) trace
+
+def Outcome (key : SecretKey) (f : QueryImpl HashSpec Id) (log : QueryLog SigningSpec)
+    (boundary : SigningBoundaryTrace) (trace : Trace) (forgery : Forgery) : Prop :=
+  TargetCertificateAt key Finset.univ (transcriptCache f boundary trace, log) (signingInput key forgery.message forgery.signature) ∨
+    NearGuess key f log boundary trace forgery ∨ TwoGuesses key f log trace forgery
+
+theorem classification (key : SecretKey) (f : QueryImpl HashSpec Id) (log : QueryLog SigningSpec)
+    (boundary : SigningBoundaryTrace) (trace : Trace) (forgery : Forgery)
+    (horigin : ∀ message signature, (⟨message, some signature⟩ : SigningEntry) ∈ log →
+      ReferenceSigningWitness.SignatureOrigin key f message signature boundary)
+    (hnew : ∀ message signature, (⟨message, some signature⟩ : SigningEntry) ∈ log →
+      messageDigestPayload key.root message signature.randomness ≠ messageDigestPayload key.root forgery.message forgery.signature.randomness)
+    (hrun : ContainsRun f trace (messageDigest key.parameter key.root forgery.message forgery.signature.randomness))
+    (hadmissible : Admissible (truncateMessageDigest (f (signingInput key forgery.message forgery.signature))))
+    (hqueries : let target := signingView key f forgery.message forgery.signature
+      ∀ tree, FtsVerifierWitness.TrueSecretQuery f key target.1 tree (target.2 tree) trace) : Outcome key f log boundary trace forgery := by
+  by_cases hall : ∀ tree, CoveredByLog key f log (signingView key f forgery.message forgery.signature) tree
+  · exact Or.inl (certificate_of_covered key f log boundary trace forgery Finset.univ horigin hnew hrun hadmissible (fun tree _ => hall tree))
+  · push Not at hall
+    obtain ⟨first, hfirst⟩ := hall
+    by_cases hrest : ∀ tree, tree ≠ first → CoveredByLog key f log (signingView key f forgery.message forgery.signature) tree
+    · refine Or.inr (Or.inl ⟨first, ?_, hfirst, hqueries first⟩)
+      exact certificate_of_covered key f log boundary trace forgery (Finset.univ.erase first) horigin hnew hrun hadmissible
+        (fun tree ht => hrest tree (Finset.mem_erase.mp ht).1)
+    · push Not at hrest
+      obtain ⟨second, hne, hsecond⟩ := hrest
+      exact Or.inr (Or.inr ⟨first, second, hne.symm, hfirst, hqueries first, hsecond, hqueries second⟩)
+
+end SphincsSecurity.Concrete.ReferenceFtsCoverage
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/ReuseCachedTargets.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/ReuseCachedTargets.lean
new file mode 100644
index 000000000..7b7d4196c
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/ReuseCachedTargets.lean
@@ -0,0 +1,150 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.ReuseRawEnvelope
+import SphincsSecurity.Proof.Fts.DigestCompletionNewTarget
+
+/-! ## NewTargetWorld -/
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (MessageHashInput)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem newTargetEnvelopeCharge_cacheQuery (key : SecretKey) (before : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (uniform reuse arrival : ENNReal) (queries signings : Nat)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (input : HashInput) (output : HashOutput)
+    (hfresh : before input = none) :
+    newTargetEnvelopeCharge key before (before.cacheQuery input output) log uniform reuse arrival queries signings groups remaining =
+      if MessageHashInput key.parameter input ∧ Admissible (truncateMessageDigest output) then
+        targetShapeEnvelope uniform reuse arrival queries signings
+          (targetShapeMoments key (before.cacheQuery input output) log (payloadOf input) (hashOutputFewTimeView output)) groups remaining else 0 := by
+  unfold newTargetEnvelopeCharge
+  rw [cacheMessageWeight_cacheQuery key.parameter _ before input output hfresh,
+    cacheMessageWeight_fresh_restriction, zero_add]
+  simp only [hfresh, if_true]
+
+end SphincsSecurity.Concrete
+
+/-! ## ExpectedNewTargetEnvelope -/
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem expected_signWithView_newTargetEnvelopeCharge_le_mass_mul (key : SecretKey) (message : Message)
+    (before : QueryCache HashSpec) (log : QueryLog SigningSpec)
+    (hsigned : SigningDigestsCached key.parameter before key.root log)
+    (uniform reuse arrival : ENNReal) (queries signings : Nat)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining) :
+    (∑' result, Pr[= result | (simulateQ romImpl (signWithView key message)).run before] *
+      newTargetEnvelopeCharge key before result.2 (log ++ [⟨message, result.1.1⟩]) uniform reuse arrival queries signings groups remaining) ≤
+        freshDigestSelectionProbability key message before *
+          ((Fintype.card Index : ENNReal)⁻¹ *
+            targetIndexEnvelope uniform reuse arrival queries signings (targetIndexMoments key before log) groups.card remaining.card) := by
+  rw [signWithView_run_eq_digestCompletion]
+  exact expected_digestCompletion_newTargetEnvelopeCharge_le_mass_mul key message before
+    (originalDigestCompletion key) id (fun loop _ result hr => originalDigestCompletion_preservesMessages key loop result hr)
+    log hsigned uniform reuse arrival queries signings groups remaining hvalid
+
+end SphincsSecurity.Concrete
+
+/-! ## FreshTargetWorld -/
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (MessageHashInput)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def freshWorldTargetHashCost (parameter : PublicParameter) (cache : QueryCache HashSpec) : OracleWorld.Domain → Nat
+  | .inl _ => 0
+  | .inr input => if MessageHashInput parameter input ∧ cache input = none then 1 else 0
+
+end SphincsSecurity.Concrete
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (MessageHashInput)
+attribute [local instance] Classical.propDecidable
+
+noncomputable abbrev reuseNewTargetEnvelope (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat)
+    (before : QueryCache HashSpec) (after : CoverLogState) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) : ENNReal :=
+  newTargetEnvelopeCharge key before after.1 after.2 (Fintype.card Index : ENNReal)⁻¹ reuse
+    (((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ * (Fintype.card Index : ENNReal)⁻¹) budget signatures groups remaining
+
+theorem expected_randomOracle_reuseNewTarget_le (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat)
+    (state : CoverLogState) (input : HashInput) (hsigned : SigningDigestsCached key.parameter state.1 key.root state.2)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining) :
+    (∑' result, Pr[= result | (randomOracle input).run state.1] *
+      reuseNewTargetEnvelope key reuse budget signatures state.1 (result.2, state.2) groups remaining) ≤
+      (freshWorldTargetHashCost key.parameter state.1 (.inr input) : ENNReal) *
+        ((((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ * (Fintype.card Index : ENNReal)⁻¹) *
+          reuseRawEnvelope key reuse budget signatures state groups remaining) := by
+  by_cases hfresh : state.1 input = none
+  · rw [randomOracle, QueryImpl.withCaching_run_none _ hfresh, tsum_probOutput_map_mul]
+    change (∑' output : HashOutput, Pr[= output | ($ᵗ HashOutput : ProbComp HashOutput)] *
+      reuseNewTargetEnvelope key reuse budget signatures state.1 (state.1.cacheQuery input output, state.2) groups remaining) ≤ _
+    simp only [reuseNewTargetEnvelope, newTargetEnvelopeCharge_cacheQuery key state.1 state.2 _ _ _ _ _ groups remaining input _ hfresh]
+    by_cases hmessage : MessageHashInput key.parameter input
+    · obtain ⟨payload, rfl⟩ := hmessage
+      simp only [show MessageHashInput key.parameter (tweakableHashInput key.parameter .message payload) from ⟨payload, rfl⟩,
+        true_and, payloadOf_tweakableHashInput, freshWorldTargetHashCost, hfresh, and_self, if_true, Nat.cast_one, one_mul]
+      rw [expected_cacheQuery_freshTargetEnvelope key state.1 state.2 payload hfresh hsigned _ _ _ _ _ groups remaining hvalid]
+      unfold reuseRawEnvelope observedRawIndexShapeVector
+      rw [targetShapeEnvelope_lift _ _ _ _ _ _ groups remaining hvalid]
+    · simp only [hmessage, false_and, if_false, mul_zero, tsum_zero, zero_le]
+  · obtain ⟨output, ho⟩ := Option.ne_none_iff_exists'.mp hfresh
+    rw [randomOracle, QueryImpl.withCaching_run_some _ ho, tsum_probOutput_pure_mul]
+    rw [reuseNewTargetEnvelope, newTargetEnvelopeCharge, cacheMessageWeight_fresh_restriction]
+    exact zero_le
+
+theorem expected_logTraced_world_reuseNewTarget_le (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat)
+    (state : CoverLogState) (input : OracleWorld.Domain) (hsigned : SigningDigestsCached key.parameter state.1 key.root state.2)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining) :
+    (∑' result, Pr[= result | (logTracedMappedAdversaryImpl key (.inl input)).run state] *
+      reuseNewTargetEnvelope key reuse budget signatures state.1 result.2 groups remaining) ≤
+      (freshWorldTargetHashCost key.parameter state.1 input : ENNReal) *
+        ((((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ * (Fintype.card Index : ENNReal)⁻¹) *
+          reuseRawEnvelope key reuse budget signatures state groups remaining) := by
+  rw [logTracedMappedAdversaryImpl_run_map, tsum_probOutput_map_mul]
+  simp only [signingLogFragment, List.append_nil]
+  cases input with
+  | inr input => exact expected_randomOracle_reuseNewTarget_le key reuse budget signatures state input hsigned groups remaining hvalid
+  | inl sample =>
+      have hrun : (unifFwdImpl HashSpec sample).run state.1 =
+          (fun output => (output, state.1)) <$> (liftM (unifSpec.query sample) : ProbComp (unifSpec.Range sample)) := by
+        simpa [simulateQ_query] using (unifFwdImpl.simulateQ_run
+          (hashSpec := HashSpec) (liftM (unifSpec.query sample) : ProbComp (unifSpec.Range sample)) state.1)
+      change (∑' result, Pr[= result | (unifFwdImpl HashSpec sample).run state.1] *
+        reuseNewTargetEnvelope key reuse budget signatures state.1 (result.2, state.2) groups remaining) ≤ _
+      rw [hrun, tsum_probOutput_map_mul]
+      simp only [reuseNewTargetEnvelope, newTargetEnvelopeCharge, cacheMessageWeight_fresh_restriction, mul_zero, tsum_zero, zero_le]
+
+theorem expected_logTraced_sign_reuseNewTarget_le_mass_mul (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat)
+    (state : CoverLogState) (hsigned : SigningDigestsCached key.parameter state.1 key.root state.2) (message : Message)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining) :
+    (∑' result, Pr[= result | (logTracedMappedAdversaryImpl key (.inr message)).run state] *
+      reuseNewTargetEnvelope key reuse budget signatures state.1 result.2 groups remaining) ≤
+      freshDigestSelectionProbability key message state.1 *
+        ((Fintype.card Index : ENNReal)⁻¹ * reuseRawEnvelope key reuse budget signatures state groups remaining) := by
+  rw [logTracedMappedAdversaryImpl_run_map, tsum_probOutput_map_mul]
+  have hrun : (unloggedMappedAdversaryImpl key (.inr message)).run state.1 =
+      (fun result => (result.1.1, result.2)) <$> (simulateQ romImpl (signWithView key message)).run state.1 :=
+    (simulateQ_signWithView_fst_run key message state.1).symm
+  have heq := congrArg (fun computation : ProbComp (Option Signature × QueryCache HashSpec) =>
+    ∑' result, Pr[= result | computation] *
+      reuseNewTargetEnvelope key reuse budget signatures state.1 (result.2, state.2 ++ [⟨message, result.1⟩]) groups remaining) hrun
+  rw [tsum_probOutput_map_mul] at heq
+  have h := expected_signWithView_newTargetEnvelopeCharge_le_mass_mul key message state.1 state.2 hsigned
+    (Fintype.card Index : ENNReal)⁻¹ reuse
+    (((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ * (Fintype.card Index : ENNReal)⁻¹) budget signatures groups remaining hvalid
+  refine heq.le.trans (h.trans_eq ?_)
+  unfold reuseRawEnvelope observedRawIndexShapeVector
+  rw [targetShapeEnvelope_lift _ _ _ _ _ _ groups remaining hvalid]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/ReuseRawEnvelope.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/ReuseRawEnvelope.lean
new file mode 100644
index 000000000..5d2d12455
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/ReuseRawEnvelope.lean
@@ -0,0 +1,30 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.TargetShapeEnvelope
+import SphincsSecurity.Proof.Fts.FreshTargetShapeAverage
+import SphincsSecurity.Proof.Fts.InterleavedCoverStep
+import SphincsSecurity.Proof.Fts.TargetShapeCardinality
+
+/-! ## WorldRawIndexEnvelope -/
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def observedRawIndexShapeVector (key : SecretKey) (state : CoverLogState) : TargetShapeVector :=
+  liftTargetIndexVector (targetIndexMoments key state.1 state.2)
+
+end SphincsSecurity.Concrete
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+
+noncomputable def reuseRawEnvelope (key : SecretKey) (reuse : ENNReal) (queries signatures : Nat)
+    (state : CoverLogState) : TargetShapeVector :=
+  targetShapeEnvelope (Fintype.card Index : ENNReal)⁻¹ reuse
+    (((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ * (Fintype.card Index : ENNReal)⁻¹) queries signatures
+    (observedRawIndexShapeVector key state)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/ReuseTargetEnvelope.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/ReuseTargetEnvelope.lean
new file mode 100644
index 000000000..cbf27ee14
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/ReuseTargetEnvelope.lean
@@ -0,0 +1,92 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.ExactTargetShapeSigning
+import SphincsSecurity.Proof.Fts.TargetShapeContinuation
+import SphincsSecurity.Proof.Fts.TargetShapeExpectation
+
+/-! ## SigningExecutionBudget -/
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+/-- Debit from the syntactic continuation bound, including repeatable digest rejection. -/
+def signingExecutionHashCost : (OracleWorld + SigningSpec).Domain → Nat
+  | .inl (.inl _) => 0
+  | .inl (.inr _) => 1
+  | .inr _ => digestAttemptLimit
+
+end SphincsSecurity.Concrete
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+
+noncomputable def reuseTargetEnvelope (key : SecretKey) (reuse : ENNReal) (budget : Nat) (payload : HashInput) (target : FewTimeView)
+    (signatures : Nat) (state : CoverLogState) : TargetShapeVector :=
+  targetShapeEnvelope (Fintype.card Index : ENNReal)⁻¹ reuse
+    (((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ * (Fintype.card Index : ENNReal)⁻¹) budget signatures
+    (observedTargetShapeVector key payload target state)
+
+theorem reuseTargetEnvelope_budget_mono (key : SecretKey) (reuse : ENNReal) (payload : HashInput) (target : FewTimeView)
+    (signatures : Nat) (state : CoverLogState) {smaller larger : Nat} (hbudget : smaller ≤ larger)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining) :
+    reuseTargetEnvelope key reuse smaller payload target signatures state groups remaining ≤
+      reuseTargetEnvelope key reuse larger payload target signatures state groups remaining :=
+  targetShapeEnvelope_queries_mono _ _ _ signatures _ hbudget groups remaining hvalid
+
+theorem expected_randomOracle_reuseTarget_le (key : SecretKey) (reuse : ENNReal) (budget : Nat) (payload : HashInput) (target : FewTimeView)
+    (signatures : Nat) (state : CoverLogState) (input : HashInput) (hsigned : SigningDigestsCached key.parameter state.1 key.root state.2)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining) :
+    (∑' result, Pr[= result | (randomOracle input).run state.1] *
+      reuseTargetEnvelope key reuse budget payload target signatures (result.2, state.2) groups remaining) ≤
+      reuseTargetEnvelope key reuse (budget + 1) payload target signatures state groups remaining := by
+  by_cases hfresh : state.1 input = none
+  · rw [randomOracle, QueryImpl.withCaching_run_none _ hfresh, tsum_probOutput_map_mul]
+    unfold reuseTargetEnvelope
+    rw [targetShapeEnvelope_expected, ← targetShapeEnvelope_query]
+    exact targetShapeEnvelope_mono _ _ _ budget signatures
+      (fun G R hv => expected_fresh_targetShape_le key payload target state.1 state.2 input hfresh hsigned G R hv)
+      groups remaining hvalid
+  · obtain ⟨output, ho⟩ := Option.ne_none_iff_exists'.mp hfresh
+    rw [randomOracle, QueryImpl.withCaching_run_some _ ho, tsum_probOutput_pure_mul]
+    exact reuseTargetEnvelope_budget_mono key reuse payload target signatures state (Nat.le_succ _) groups remaining hvalid
+
+theorem expected_logTraced_world_reuseTarget_le (key : SecretKey) (reuse : ENNReal) (budget : Nat) (payload : HashInput) (target : FewTimeView)
+    (signatures : Nat) (state : CoverLogState) (input : OracleWorld.Domain) (hsigned : SigningDigestsCached key.parameter state.1 key.root state.2)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining) :
+    (∑' result, Pr[= result | (logTracedMappedAdversaryImpl key (.inl input)).run state] *
+      reuseTargetEnvelope key reuse budget payload target signatures result.2 groups remaining) ≤
+      reuseTargetEnvelope key reuse (budget + signingExecutionHashCost (.inl input)) payload target signatures state groups remaining := by
+  rw [logTracedMappedAdversaryImpl_run_map, tsum_probOutput_map_mul]
+  simp only [signingLogFragment, List.append_nil]
+  cases input with
+  | inr input => exact expected_randomOracle_reuseTarget_le key reuse budget payload target signatures state input hsigned groups remaining hvalid
+  | inl sample =>
+      have hrun : (unifFwdImpl HashSpec sample).run state.1 =
+          (fun output => (output, state.1)) <$> (liftM (unifSpec.query sample) : ProbComp (unifSpec.Range sample)) := by
+        simpa [simulateQ_query] using (unifFwdImpl.simulateQ_run
+          (hashSpec := HashSpec) (liftM (unifSpec.query sample) : ProbComp (unifSpec.Range sample)) state.1)
+      change (∑' result, Pr[= result | (unifFwdImpl HashSpec sample).run state.1] *
+        reuseTargetEnvelope key reuse budget payload target signatures (result.2, state.2) groups remaining) ≤ _
+      rw [hrun, tsum_probOutput_map_mul]
+      dsimp only
+      rw [ENNReal.tsum_mul_right]
+      exact mul_le_of_le_one_left' tsum_probOutput_le_one
+
+theorem expected_logTraced_sign_reuseTarget_le (key : SecretKey) (reuse : ENNReal) (budget : Nat) (payload : HashInput) (target : FewTimeView)
+    (signatures : Nat) (state : CoverLogState)
+    (hsigned : SigningDigestsCached key.parameter state.1 key.root state.2) (message : Message)
+    (hreuse : exactDigestReuseWeight key message state.1 ≤ reuse)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining) :
+    (∑' result, Pr[= result | (logTracedMappedAdversaryImpl key (.inr message)).run state] *
+      reuseTargetEnvelope key reuse budget payload target signatures result.2 groups remaining) ≤
+      reuseTargetEnvelope key reuse budget payload target (signatures + 1) state groups remaining := by
+  unfold reuseTargetEnvelope
+  rw [targetShapeEnvelope_expected]
+  exact (targetShapeEnvelope_mono _ _ _ budget signatures
+    (fun G R hv => expected_logTraced_sign_targetShape_le_of_exactReuse key reuse payload target state hsigned message hreuse G R hv)
+      groups remaining hvalid).trans
+    (targetShapeEnvelope_signing_le _ _ _ budget signatures _ groups remaining hvalid)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/SelectedDigestCache.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/SelectedDigestCache.lean
new file mode 100644
index 000000000..52cc2ebcc
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/SelectedDigestCache.lean
@@ -0,0 +1,42 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FewTimeSignerView
+import SphincsSecurity.Proof.Fts.SignerDigestSource
+import SphincsSecurity.Proof.Fts.TerminalCache
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+theorem signDigestLoop_selected_cached_output (attempts : Nat) (key : SecretKey) (message : Message)
+    (before after : QueryCache HashSpec) (randomness : Randomness) (index : Index) (leaves : IndexGroup → FtsLeaf)
+    (hloop : (some (randomness, index, leaves), after) ∈ support ((simulateQ romImpl (signDigestLoop attempts key message)).run before)) :
+    ∃ output, after (tweakableHashInput key.parameter .message (messageDigestPayload key.root message randomness)) = some output ∧
+      Admissible (truncateMessageDigest output) ∧ hashOutputFewTimeView output = selectedFewTimeView index leaves := by
+  have hreplay := replayRom_of_mem_support (signDigestLoop attempts key message) before
+    (some (randomness, index, leaves)) after hloop (fromCache after) (agreesWithFn_fromCache after)
+  have hgood := successfulDigestLoop_of_mem_support (fromCache after) key message attempts randomness index leaves
+    before after after hreplay le_rfl (agreesWithFn_fromCache after)
+  obtain ⟨_, digest, heval, hadmissible, hindex, hleaves, hcached⟩ := hgood.extract
+  obtain ⟨output, houtput⟩ := Option.ne_none_iff_exists'.mp (CachedRun.messageDigest_cached hcached)
+  have hdigest : digest = truncateMessageDigest output := by
+    rw [← heval]
+    change truncateMessageDigest (fromCache after (tweakableHashInput key.parameter .message
+      (messageDigestPayload key.root message randomness))) = truncateMessageDigest output
+    rw [agreesWithFn_fromCache after houtput]
+  refine ⟨output, houtput, hdigest ▸ hadmissible, ?_⟩
+  simp only [hashOutputFewTimeView, selectedFewTimeView, ← hdigest, hindex, hleaves]
+
+theorem signAfterDigest_message_cache_eq (key : SecretKey) (randomness : Randomness) (index : Index)
+    (leaves : IndexGroup → FtsLeaf) (before after : QueryCache HashSpec) (signature : Option Signature)
+    (hfinish : (signature, after) ∈ support ((simulateQ (randomOracle : QueryImpl HashSpec _)
+      (signAfterDigest key randomness index leaves)).run before)) (payload : HashInput) :
+    after (tweakableHashInput key.parameter .message payload) = before (tweakableHashInput key.parameter .message payload) := by
+  cases hbefore : before (tweakableHashInput key.parameter .message payload) with
+  | none => exact signAfterDigest_cache_message_none key randomness index leaves before after signature hfinish payload hbefore
+  | some output =>
+      have hcache : before ≤ after :=
+        (replay_of_mem_support (signAfterDigest key randomness index leaves) before signature after hfinish
+          (fromCache after) (agreesWithFn_fromCache after)).1
+      exact hcache hbefore
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/SignerAdmissibleMessage.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/SignerAdmissibleMessage.lean
new file mode 100644
index 000000000..6d67917ae
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/SignerAdmissibleMessage.lean
@@ -0,0 +1,91 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FewTimeSignerView
+import SphincsSecurity.Proof.Fts.MessagePrehit
+import SphincsSecurity.Proof.Fts.SignerDigestSource
+import SphincsSecurity.Proof.Fts.TerminalCache
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+theorem signWithView_successful_cached_output (key : SecretKey) (message : Message)
+    (before after : QueryCache HashSpec) (signature : Signature) (view : Option FewTimeView)
+    (hresult : ((some signature, view), after) ∈ support ((simulateQ romImpl (signWithView key message)).run before)) :
+    ∃ output, after (tweakableHashInput key.parameter .message
+        (messageDigestPayload key.root message signature.randomness)) = some output ∧
+      Admissible (truncateMessageDigest output) ∧ view = some (hashOutputFewTimeView output) := by
+  obtain ⟨randomness, index, leaves, loopCache, hloop, hfinish, hview⟩ :=
+    signWithView_support_some key message before after signature view hresult
+  have hrandomness := signAfterDigest_support_some_randomness key randomness index leaves loopCache after signature hfinish
+  have hloopLe : loopCache ≤ after :=
+    (replay_of_mem_support (signAfterDigest key randomness index leaves) loopCache (some signature) after hfinish
+      (fromCache after) (agreesWithFn_fromCache after)).1
+  have hf : loopCache.AgreesWithFn (fromCache after) := fun _ _ h => agreesWithFn_fromCache after (hloopLe h)
+  have hreplay := replayRom_of_mem_support (signDigestLoop digestAttemptLimit key message) before
+    (some (randomness, index, leaves)) loopCache hloop (fromCache after) hf
+  have hgood := successfulDigestLoop_of_mem_support (fromCache after) key message digestAttemptLimit randomness index leaves
+    before loopCache after hreplay hloopLe (agreesWithFn_fromCache after)
+  obtain ⟨_, digest, heval, hadmissible, hindex, hleaves, hcached⟩ := hgood.extract
+  obtain ⟨output, houtput⟩ := Option.ne_none_iff_exists'.mp (CachedRun.messageDigest_cached hcached)
+  have hdigest : digest = truncateMessageDigest output := by
+    rw [← heval]
+    change truncateMessageDigest (fromCache after (tweakableHashInput key.parameter .message
+      (messageDigestPayload key.root message randomness))) = truncateMessageDigest output
+    rw [agreesWithFn_fromCache after houtput]
+  refine ⟨output, ?_, hdigest ▸ hadmissible, ?_⟩
+  · rw [hrandomness]
+    exact houtput
+  · simpa only [selectedFewTimeView, hindex, hleaves, hdigest, hashOutputFewTimeView] using hview
+
+theorem signDigestLoop_new_admissible_selected (attempts : Nat) (key : SecretKey) (message : Message)
+    (before after : QueryCache HashSpec) (result : Option (Randomness × Index × (IndexGroup → FtsLeaf)))
+    (hresult : (result, after) ∈ support ((simulateQ romImpl (signDigestLoop attempts key message)).run before))
+    (payload : HashInput) (output : HashOutput)
+    (hbefore : before (tweakableHashInput key.parameter .message payload) = none)
+    (hafter : after (tweakableHashInput key.parameter .message payload) = some output)
+    (hadmissible : Admissible (truncateMessageDigest output)) :
+    ∃ randomness index leaves, result = some (randomness, index, leaves) ∧
+      payload = messageDigestPayload key.root message randomness := by
+  induction attempts generalizing before after result with
+  | zero =>
+      have heq : (result, after) = (none, before) := by
+        simpa only [signDigestLoop, simulateQ_pure, StateT.run_pure, support_pure, Set.mem_singleton_iff] using hresult
+      have hcache : after = before := congrArg Prod.snd heq
+      rw [hcache, hbefore] at hafter
+      contradiction
+  | succ attempts ih =>
+      rw [signDigestLoop_run_succ_eq, mem_support_bind_iff] at hresult
+      obtain ⟨sampled, _, hrest⟩ := hresult
+      rw [mem_support_bind_iff] at hrest
+      obtain ⟨⟨attempt, attemptCache⟩, hattempt, hfinish⟩ := hrest
+      cases attempt with
+      | none =>
+          simp only [signDigestLoopContinuation] at hfinish
+          by_cases hsame : payload = messageDigestPayload key.root message sampled
+          · have hle := simulateQ_romImpl_cache_le (signDigestLoop attempts key message) attemptCache (result, after) hfinish
+            have heval := (replay_of_mem_support_of_le (signAttempt key message sampled) before none attemptCache after hattempt hle
+              (fromCache after) (agreesWithFn_fromCache after)).1
+            have hanswer : fromCache after (tweakableHashInput key.parameter .message
+                (messageDigestPayload key.root message sampled)) = output :=
+              agreesWithFn_fromCache after (hsame ▸ hafter)
+            simp only [signAttempt, messageDigest, oracleHash, evalWithAnswerFn_bind, evalWithAnswerFn_query,
+              hanswer, evalWithAnswerFn_pure, hadmissible, if_pos] at heval
+            exact False.elim (by simp only [reduceCtorEq] at heval)
+          · have hnone := signAttempt_cache_other_none key message sampled before attemptCache none hattempt
+              (tweakableHashInput key.parameter .message payload) hbefore (fun h =>
+                hsame (tweakableHashInput_injective key.parameter (by trivial) (by trivial) h).2)
+            exact ih attemptCache after result hfinish hnone hafter
+      | some selected =>
+          obtain ⟨index, leaves⟩ := selected
+          have heq : (result, after) = (some (sampled, index, leaves), attemptCache) := by
+            simpa only [signDigestLoopContinuation, support_pure, Set.mem_singleton_iff] using hfinish
+          by_cases hsame : payload = messageDigestPayload key.root message sampled
+          · exact ⟨sampled, index, leaves, congrArg Prod.fst heq, hsame⟩
+          · have hnone := signAttempt_cache_other_none key message sampled before attemptCache (some (index, leaves)) hattempt
+              (tweakableHashInput key.parameter .message payload) hbefore (fun h =>
+                hsame (tweakableHashInput_injective key.parameter (by trivial) (by trivial) h).2)
+            have hcache : after = attemptCache := congrArg Prod.snd heq
+            rw [hcache, hnone] at hafter
+            exact False.elim (by simp only [reduceCtorEq] at hafter)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/SignerDigestSource.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/SignerDigestSource.lean
new file mode 100644
index 000000000..14cf9ed29
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/SignerDigestSource.lean
@@ -0,0 +1,58 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Scheme.NoMessage
+/-!
+# 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 × (IndexGroup → 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 : IndexGroup → 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
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/SigningProposalRecord.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/SigningProposalRecord.lean
new file mode 100644
index 000000000..5884cf89f
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/SigningProposalRecord.lean
@@ -0,0 +1,168 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.AdaptiveProposalWords
+import SphincsSecurity.Proof.Fts.DigestSelectionIndex
+import SphincsSecurity.Proof.Fts.ProposalBridgeKernel
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] signDigestLoop signAfterDigest
+
+private theorem probCompLift_apply {α : Type} (comp : ProbComp α) (value : α) :
+    (liftM comp : PMF α) value = Pr[= value | comp] := by
+  rw [← PMF.probOutput_eq_apply]
+  rfl
+
+theorem probOutput_completeSigningIndex_eq_loop (key : SecretKey) (message : Message)
+    (cache : QueryCache HashSpec) (index : Index) :
+    Pr[= index | (simulateQ romImpl (signWithView key message)).run cache >>=
+      fun result => completeSelectedIndex result.1.2] =
+    Pr[= index | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run cache >>=
+      fun result => completeSelectedIndex (selectedLoopView? result)] := by
+  rw [signWithView, simulateQ_bind, StateT.run_bind, bind_assoc]
+  apply probOutput_bind_congr
+  rintro ⟨selected, loopCache⟩ _
+  cases selected with
+  | none => simp only [simulateQ_pure, StateT.run_pure, pure_bind, selectedLoopView?, Option.map_none]
+  | some selected =>
+      obtain ⟨randomness, selectedIndex, leaves⟩ := selected
+      simp only [simulateQ_bind, StateT.run_bind, bind_assoc, simulateQ_pure, StateT.run_pure,
+        pure_bind, selectedLoopView?, Option.map_some]
+      simp
+
+abbrev TracedSigningRecord (ω : Type) :=
+  ((Option Signature × Option FewTimeView) × ω) × QueryCache HashSpec
+
+noncomputable def tracedSigningRun {ω : Type} [Monoid ω]
+    (trace : (input : OracleWorld.Domain) → OracleWorld.Range input → ω)
+    (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) : ProbComp (TracedSigningRecord ω) :=
+  ((simulateQ (romImpl.withTrace trace) (signWithView key message)).run).run cache
+
+theorem tracedSigningRun_forget {ω : Type} [Monoid ω]
+    (trace : (input : OracleWorld.Domain) → OracleWorld.Range input → ω)
+    (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) :
+    (fun result : TracedSigningRecord ω => (result.1.1, result.2)) <$>
+      tracedSigningRun trace key message cache = (simulateQ romImpl (signWithView key message)).run cache := by
+  have h := congrArg (fun comp : StateT (QueryCache HashSpec) ProbComp (Option Signature × Option FewTimeView) => comp.run cache)
+    (QueryImpl.fst_map_run_withTrace romImpl trace (signWithView key message))
+  simpa only [StateT.run_map, tracedSigningRun] using h
+
+def signingRecordResponse {ω : Type} (result : TracedSigningRecord ω) :
+    (Option Signature × ω) × QueryCache HashSpec :=
+  ((result.1.1.1, result.1.2), result.2)
+
+theorem tracedSigningRun_signature {ω : Type} [Monoid ω]
+    (trace : (input : OracleWorld.Domain) → OracleWorld.Range input → ω)
+    (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) :
+    signingRecordResponse <$> tracedSigningRun trace key message cache =
+      ((simulateQ (romImpl.withTrace trace) (sign key message)).run).run cache := by
+  change (fun result : TracedSigningRecord ω => ((result.1.1.1, result.1.2), result.2)) <$>
+    tracedSigningRun trace key message cache = _
+  have h := congrArg (fun comp : OracleComp OracleWorld (Option Signature) =>
+    ((simulateQ (romImpl.withTrace trace) comp).run).run cache) (signWithView_fst key message)
+  simpa only [simulateQ_map, WriterT.run_map, StateT.run_map, tracedSigningRun] using h
+
+theorem probOutput_tracedSigningIndex_eq_loop {ω : Type} [Monoid ω]
+    (trace : (input : OracleWorld.Domain) → OracleWorld.Range input → ω)
+    (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) (index : Index) :
+    Pr[= index | tracedSigningRun trace key message cache >>= fun result => completeSelectedIndex result.1.1.2] =
+    Pr[= index | (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run cache >>=
+      fun result => completeSelectedIndex (selectedLoopView? result)] := by
+  rw [← probOutput_completeSigningIndex_eq_loop, ← tracedSigningRun_forget trace key message cache]
+  simp only [map_eq_bind_pure_comp, bind_assoc, pure_bind, Function.comp_def]
+
+noncomputable def completedSigningRecord {ω : Type} [Monoid ω]
+    (trace : (input : OracleWorld.Domain) → OracleWorld.Range input → ω)
+    (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) : PMF (TracedSigningRecord ω × Index) :=
+  (liftM (tracedSigningRun trace key message cache) : PMF (TracedSigningRecord ω)).bind fun result =>
+    (liftM (completeSelectedIndex result.1.1.2) : PMF Index).map (fun index => (result, index))
+
+theorem completedSigningRecord_forget {ω : Type} [Monoid ω]
+    (trace : (input : OracleWorld.Domain) → OracleWorld.Range input → ω)
+    (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) :
+    (completedSigningRecord trace key message cache).map Prod.fst =
+      (liftM (tracedSigningRun trace key message cache) : PMF (TracedSigningRecord ω)) := by
+  rw [completedSigningRecord, PMF.map_bind]
+  have hbranch (result : TracedSigningRecord ω) :
+      ((liftM (completeSelectedIndex result.1.1.2) : PMF Index).map
+        (fun index => (result, index))).map Prod.fst = PMF.pure result := by
+    rw [PMF.map_comp]
+    exact PMF.map_const _ result
+  simp_rw [hbranch]
+  exact PMF.bind_pure _
+
+theorem completedSigningRecord_index {ω : Type} [Monoid ω]
+    (trace : (input : OracleWorld.Domain) → OracleWorld.Range input → ω)
+    (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) :
+    (completedSigningRecord trace key message cache).map Prod.snd =
+      (liftM (tracedSigningRun trace key message cache >>= fun result => completeSelectedIndex result.1.1.2) : PMF Index) := by
+  rw [completedSigningRecord, PMF.map_bind]
+  have hbranch (result : TracedSigningRecord ω) :
+      ((liftM (completeSelectedIndex result.1.1.2) : PMF Index).map
+        (fun index => (result, index))).map Prod.snd = liftM (completeSelectedIndex result.1.1.2) := by
+    rw [PMF.map_comp]
+    exact PMF.map_id _
+  simp_rw [hbranch]
+  exact (liftM_bind (m := ProbComp) (n := PMF) _ _).symm
+
+theorem completedSigningRecord_index_le {ω : Type} [Monoid ω]
+    (trace : (input : OracleWorld.Domain) → OracleWorld.Range input → ω)
+    (key : SecretKey) (message : Message) (cache : QueryCache HashSpec)
+    (spent : Nat) (hspent : spent ≤ 2 ^ 127) (hcache : QueryCache.enncard cache ≤ spent)
+    (hclean : ¬ MessageDeficitExceptional key cache)
+    (hindex : ∀ index, cachedIndexMultiplicity key.parameter cache index ≤
+      (spent : ENNReal) * ((2 ^ 36 : Nat) : ENNReal)⁻¹ + ((2 ^ 80 : Nat) : ENNReal)) (index : Index) :
+    ((completedSigningRecord trace key message cache).map Prod.snd) index ≤ targetProposalIndexRate := by
+  rw [completedSigningRecord_index, probCompLift_apply, probOutput_tracedSigningIndex_eq_loop]
+  exact probOutput_completeSelectedLoopIndex_le_proposalRate key message cache spent hspent hcache hclean hindex index
+
+theorem completedSigningRecord_selected_index {ω : Type} [Monoid ω]
+    (trace : (input : OracleWorld.Domain) → OracleWorld.Range input → ω)
+    (key : SecretKey) (message : Message) (cache : QueryCache HashSpec)
+    (record : TracedSigningRecord ω) (index : Index) (view : FewTimeView)
+    (hr : (record, index) ∈ (completedSigningRecord trace key message cache).support)
+    (hview : record.1.1.2 = some view) : index = view.1 := by
+  rw [completedSigningRecord, PMF.mem_support_bind_iff] at hr
+  obtain ⟨source, _, hr⟩ := hr
+  rw [PMF.mem_support_map_iff] at hr
+  obtain ⟨selected, hselected, heq⟩ := hr
+  obtain ⟨rfl, rfl⟩ := Prod.mk.inj heq
+  simpa only [hview, completeSelectedIndex, Option.elim_some, liftM_pure,
+    PMF.monad_pure_eq_pure, PMF.support_pure, Set.mem_singleton_iff] using hselected
+
+abbrev SigningBoundaryTrace := FreeMonoid (Option (HashInput × HashOutput))
+
+noncomputable def signingBoundaryTrace (parameter : PublicParameter) :
+    (input : OracleWorld.Domain) → OracleWorld.Range input → SigningBoundaryTrace
+  | .inl _, _ => 1
+  | .inr input, output => FreeMonoid.of
+      (if FtsProbeSimulation.MessageHashInput parameter input then some (input, output) else none)
+
+def SigningBoundaryTrace.hashCalls (trace : SigningBoundaryTrace) : Nat := trace.toList.length
+
+def SigningBoundaryTrace.messageCalls (trace : SigningBoundaryTrace) : List (HashInput × HashOutput) :=
+  trace.toList.filterMap id
+
+theorem signingBoundaryTrace_nonmessage (parameter : PublicParameter) (input : HashInput) (output : HashOutput)
+    (hinput : ¬ FtsProbeSimulation.MessageHashInput parameter input) :
+    signingBoundaryTrace parameter (.inr input) output = FreeMonoid.of none := by
+  simp only [signingBoundaryTrace, if_neg hinput]
+
+structure ProposalCacheBound (key : SecretKey) (cache : QueryCache HashSpec) (spent : Nat) : Prop where
+  spent_le : spent ≤ 2 ^ 127
+  cache_le : QueryCache.enncard cache ≤ spent
+  no_deficit : ¬ MessageDeficitExceptional key cache
+  index_le : ∀ index, cachedIndexMultiplicity key.parameter cache index ≤
+    (spent : ENNReal) * ((2 ^ 36 : Nat) : ENNReal)⁻¹ + ((2 ^ 80 : Nat) : ENNReal)
+
+theorem completedSigningRecord_acceptance_cap {ω : Type} [Monoid ω]
+    (trace : (input : OracleWorld.Domain) → OracleWorld.Range input → ω)
+    (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) (spent : Nat)
+    (hbound : ProposalCacheBound key cache spent) (index : Index) :
+    targetProposalAcceptance * ((completedSigningRecord trace key message cache).map Prod.snd) index ≤
+      PMF.uniformOfFintype Index index :=
+  targetProposalAcceptance_cap (completedSigningRecord trace key message cache) Prod.snd
+    (completedSigningRecord_index_le trace key message cache spent hbound.spent_le hbound.cache_le
+      hbound.no_deficit hbound.index_le) index
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/SingleMessageCacheGrowth.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/SingleMessageCacheGrowth.lean
new file mode 100644
index 000000000..3e33018a5
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/SingleMessageCacheGrowth.lean
@@ -0,0 +1,58 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CacheMessageWeight
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (MessageHashInput)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem cacheMessageWeight_of_no_new (parameter : PublicParameter) (weight : HashInput → FewTimeView → ENNReal)
+    (before after : QueryCache HashSpec) (hcache : before ≤ after)
+    (hnoNew : ∀ input output, before input = none → MessageHashInput parameter input → after input = some output →
+      ¬ Admissible (truncateMessageDigest output)) :
+    cacheMessageWeight parameter weight after = cacheMessageWeight parameter weight before := by
+  rw [cacheMessageWeight_of_le parameter weight before after hcache]
+  have hzero : cacheMessageWeight parameter (fun input source => if before input = none then weight input source else 0) after = 0 := by
+    unfold cacheMessageWeight
+    apply ENNReal.tsum_eq_zero.mpr
+    intro input
+    unfold cacheMessageEntryWeight
+    cases houtput : after input with
+    | none => rfl
+    | some output =>
+        simp only
+        by_cases hgood : MessageHashInput parameter input ∧ Admissible (truncateMessageDigest output)
+        · rw [if_pos hgood]
+          by_cases hfresh : before input = none
+          · exact (hnoNew input output hfresh hgood.1 houtput hgood.2).elim
+          · simp only [hfresh, if_false]
+        · simp only [hgood, if_false]
+  rw [hzero, add_zero]
+
+theorem cacheMessageWeight_of_single_new (parameter : PublicParameter) (weight : HashInput → FewTimeView → ENNReal)
+    (before after : QueryCache HashSpec) (hcache : before ≤ after) (input : HashInput) (output : HashOutput)
+    (hfresh : before input = none) (hmessage : MessageHashInput parameter input) (hafter : after input = some output)
+    (hadmissible : Admissible (truncateMessageDigest output))
+    (hunique : ∀ other answer, before other = none → MessageHashInput parameter other → after other = some answer →
+      Admissible (truncateMessageDigest answer) → other = input) :
+    cacheMessageWeight parameter weight after = cacheMessageWeight parameter weight before + weight input (hashOutputFewTimeView output) := by
+  rw [cacheMessageWeight_of_le parameter weight before after hcache]
+  congr 1
+  unfold cacheMessageWeight
+  rw [tsum_eq_single input]
+  · simp only [cacheMessageEntryWeight, hafter, hmessage, hadmissible, and_self, if_true, hfresh]
+  · intro other hne
+    unfold cacheMessageEntryWeight
+    cases hanswer : after other with
+    | none => rfl
+    | some answer =>
+        simp only
+        by_cases hgood : MessageHashInput parameter other ∧ Admissible (truncateMessageDigest answer)
+        · rw [if_pos hgood]
+          by_cases hbefore : before other = none
+          · exact (hne (hunique other answer hbefore hgood.1 hanswer hgood.2)).elim
+          · simp only [hbefore, if_false]
+        · simp only [hgood, if_false]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/SourceGroupExpectation.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/SourceGroupExpectation.lean
new file mode 100644
index 000000000..963fe8d81
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/SourceGroupExpectation.lean
@@ -0,0 +1,117 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.NormalizedTargetMatches
+
+/-! ## TargetBlockExpectation -/
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem sourceSubsetMatch_symm (target source : FewTimeView) (required : Finset FtsTree) :
+    sourceSubsetMatch target source required = sourceSubsetMatch source target required := by
+  unfold sourceSubsetMatch
+  apply Finset.prod_congr rfl
+  intro tree _
+  simp only [sourceTreeMatch, eq_comm]
+
+theorem sourceSubsetMatch_index_leaf (source : FewTimeView) (required : Finset FtsTree) (hne : required.Nonempty)
+    (index : Index) (leaves : FtsTree → FtsLeaf) :
+    sourceSubsetMatch (index, leaves) source required =
+      (if source.1 = index then 1 else 0) * ∏ tree ∈ required, (if leaves tree = source.2 tree then 1 else 0) := by
+  rw [sourceSubsetMatch_symm, sourceSubsetMatch_index source required hne]
+  by_cases hi : index = source.1 <;> simp only [hi, eq_comm, if_true, if_false, one_mul, zero_mul]
+
+end SphincsSecurity.Concrete
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def sourceGroupLeaves {α : Type} (groups : α → Finset FtsTree) (sources : α → FewTimeView) (tree : FtsTree) : FtsLeaf :=
+  if h : ∃ slot, tree ∈ groups slot then (sources h.choose).2 tree else default
+
+theorem sourceGroupLeaves_of_mem {α : Type} (groups : α → Finset FtsTree) (sources : α → FewTimeView)
+    (hdisjoint : Pairwise (fun i j => Disjoint (groups i) (groups j))) (slot : α) (tree : FtsTree) (htree : tree ∈ groups slot) :
+    sourceGroupLeaves groups sources tree = (sources slot).2 tree := by
+  have hex : ∃ slot, tree ∈ groups slot := ⟨slot, htree⟩
+  have heq : hex.choose = slot := by
+    by_contra hne
+    exact Finset.disjoint_left.mp (hdisjoint hne) hex.choose_spec htree
+  simp only [sourceGroupLeaves, dif_pos hex, heq]
+
+theorem sum_leaf_sourceGroupMatches {α : Type} [Fintype α] (groups : α → Finset FtsTree)
+    (hne : ∀ slot, (groups slot).Nonempty) (hdisjoint : Pairwise (fun i j => Disjoint (groups i) (groups j)))
+    (sources : α → FewTimeView) (index : Index) :
+    (∑ leaves : FtsTree → FtsLeaf, ∏ slot : α, sourceSubsetMatch (index, leaves) (sources slot) (groups slot)) =
+      Fintype.card FtsLeaf ^ (Fintype.card FtsTree - (Finset.univ.biUnion groups).card) *
+        ∏ slot : α, if (sources slot).1 = index then 1 else 0 := by
+  classical
+  have hprod (leaves : FtsTree → FtsLeaf) :
+      (∏ slot : α, ∏ tree ∈ groups slot, if leaves tree = (sources slot).2 tree then 1 else 0) =
+        ∏ tree ∈ Finset.univ.biUnion groups, if leaves tree = sourceGroupLeaves groups sources tree then 1 else 0 := by
+    rw [Finset.prod_biUnion (fun i _ j _ hij => hdisjoint hij)]
+    apply Finset.prod_congr rfl
+    intro slot _
+    apply Finset.prod_congr rfl
+    intro tree htree
+    rw [sourceGroupLeaves_of_mem groups sources hdisjoint slot tree htree]
+  simp only [sourceSubsetMatch_index_leaf _ _ (hne _), Finset.prod_mul_distrib, hprod, ← Finset.mul_sum]
+  rw [sum_leaf_partial_product (Finset.univ.biUnion groups)
+    (fun tree leaf => if leaf = sourceGroupLeaves groups sources tree then 1 else 0)]
+  simp only [Finset.sum_ite_eq', Finset.mem_univ, if_true, Finset.prod_const_one, mul_one]
+  exact mul_comm _ _
+
+theorem sum_sourceGroupMatches {α : Type} [Fintype α] (groups : α → Finset FtsTree)
+    (hne : ∀ slot, (groups slot).Nonempty) (hdisjoint : Pairwise (fun i j => Disjoint (groups i) (groups j)))
+    (sources : α → FewTimeView) :
+    (∑ target : FewTimeView, ∏ slot : α, sourceSubsetMatch target (sources slot) (groups slot)) =
+      Fintype.card FtsLeaf ^ (Fintype.card FtsTree - (Finset.univ.biUnion groups).card) *
+        ∑ index : Index, ∏ slot : α, if (sources slot).1 = index then 1 else 0 := by
+  rw [Fintype.sum_prod_type, Finset.mul_sum]
+  exact Finset.sum_congr rfl (fun index _ => sum_leaf_sourceGroupMatches groups hne hdisjoint sources index)
+
+theorem normalized_target_leaf_rate (required : Finset FtsTree) :
+    (Fintype.card FtsLeaf ^ required.card : Nat) *
+      ((Fintype.card FtsLeaf ^ (Fintype.card FtsTree - required.card) : Nat) / (Fintype.card FewTimeView : ENNReal)) =
+        (Fintype.card Index : ENNReal)⁻¹ := by
+  have hcard : Fintype.card FewTimeView = Fintype.card FtsLeaf ^ Fintype.card FtsTree * Fintype.card Index := by
+    simp only [FewTimeView, Fintype.card_prod, Fintype.card_fun]
+    exact mul_comm _ _
+  have hle : required.card ≤ Fintype.card FtsTree := Finset.card_le_univ required
+  have hexp : required.card + (Fintype.card FtsTree - required.card) = Fintype.card FtsTree := by omega
+  have hzero : ((Fintype.card FtsLeaf ^ Fintype.card FtsTree : Nat) : ENNReal) ≠ 0 :=
+    Nat.cast_ne_zero.mpr (pow_ne_zero _ (ne_of_gt Fintype.card_pos))
+  have hfinite : ((Fintype.card FtsLeaf ^ Fintype.card FtsTree : Nat) : ENNReal) ≠ ∞ := ENNReal.natCast_ne_top _
+  rw [div_eq_mul_inv, ← mul_assoc, ← Nat.cast_mul, ← pow_add, hexp, hcard,
+    Nat.cast_mul, ENNReal.mul_inv (Or.inl hzero) (Or.inl hfinite),
+    ← mul_assoc, ENNReal.mul_inv_cancel hzero hfinite, one_mul]
+
+theorem expected_normalized_sourceGroupMatches {α : Type} [Fintype α] (groups : α → Finset FtsTree)
+    (hne : ∀ slot, (groups slot).Nonempty) (hdisjoint : Pairwise (fun i j => Disjoint (groups i) (groups j)))
+    (sources : α → FewTimeView) :
+    (∑' target, Pr[= target | ($ᵗ FewTimeView : ProbComp FewTimeView)] *
+      ∏ slot : α, normalizedSourceSubsetMatch target (sources slot) (groups slot)) =
+        (Fintype.card Index : ENNReal)⁻¹ *
+          ∑ index : Index, ∏ slot : α, if (sources slot).1 = index then (1 : ENNReal) else 0 := by
+  classical
+  have hcard : (Finset.univ.biUnion groups).card = ∑ slot : α, (groups slot).card :=
+    Finset.card_biUnion (fun i _ j _ hij => hdisjoint hij)
+  simp only [normalizedSourceSubsetMatch, Finset.prod_mul_distrib, ← Nat.cast_prod,
+    Finset.prod_pow_eq_pow_sum, ← hcard, probOutput_uniformSample, tsum_fintype]
+  rw [← Finset.mul_sum, ← Finset.mul_sum, ← Nat.cast_sum, sum_sourceGroupMatches groups hne hdisjoint sources, Nat.cast_mul]
+  calc
+    _ = ((Fintype.card FtsLeaf ^ (Finset.univ.biUnion groups).card : Nat) *
+        ((Fintype.card FtsLeaf ^ (Fintype.card FtsTree - (Finset.univ.biUnion groups).card) : Nat) /
+          (Fintype.card FewTimeView : ENNReal))) *
+        (∑ index : Index, ∏ slot : α, if (sources slot).1 = index then 1 else 0 : Nat) := by
+      simp only [div_eq_mul_inv]
+      ring
+    _ = _ := by
+      rw [normalized_target_leaf_rate]
+      simp only [Nat.cast_sum, Nat.cast_prod, Nat.cast_ite, Nat.cast_one, Nat.cast_zero]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/StoppedSigningLog.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/StoppedSigningLog.lean
new file mode 100644
index 000000000..7c85de3e3
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/StoppedSigningLog.lean
@@ -0,0 +1,26 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Ots.OtsProbeOrigin
+namespace SphincsSecurity.Concrete.FtsProbeSimulation
+
+open _root_.OracleComp OracleSpec ENNReal
+set_option backward.isDefEq.respectTransparency false
+
+def withSigningLog (computation : OracleComp (OracleWorld + SigningSpec) α) (log : QueryLog SigningSpec) :
+    OracleComp (OracleWorld + SigningSpec) (α × QueryLog SigningSpec) :=
+  (fun result => (result.1, log ++ result.2)) <$> signingTraceComputation computation
+
+@[simp] theorem withSigningLog_pure (value : α) (log : QueryLog SigningSpec) :
+    withSigningLog (pure value) log = pure (value, log) := by
+  simp [withSigningLog, signingTraceComputation]
+
+theorem withSigningLog_query_bind (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) α) (log : QueryLog SigningSpec) :
+    withSigningLog (OracleSpec.query input >>= next) log =
+      (liftM (OracleSpec.query input) : OracleComp (OracleWorld + SigningSpec) _) >>= fun output =>
+        withSigningLog (next output) (log ++ signingLogFragment input output) := by
+  rw [withSigningLog, signingTraceComputation_query_bind, map_bind]
+  apply bind_congr
+  intro output
+  simp only [withSigningLog, Functor.map_map, List.append_assoc]
+
+end SphincsSecurity.Concrete.FtsProbeSimulation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/SubsetTargetAssignment.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/SubsetTargetAssignment.lean
new file mode 100644
index 000000000..97f870c31
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/SubsetTargetAssignment.lean
@@ -0,0 +1,34 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.TargetAssignmentCount
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def sourceSubsetMatch (target source : FewTimeView) (required : Finset FtsTree) : Nat :=
+  ∏ tree ∈ required, sourceTreeMatch target source tree
+
+theorem sourceTreeMatch_mul_self (target source : FewTimeView) (tree : FtsTree) :
+    sourceTreeMatch target source tree * sourceTreeMatch target source tree = sourceTreeMatch target source tree := by
+  unfold sourceTreeMatch
+  split_ifs <;> decide
+
+theorem sourceSubsetMatch_mul (target source : FewTimeView) (left right : Finset FtsTree) :
+    sourceSubsetMatch target source left * sourceSubsetMatch target source right =
+      sourceSubsetMatch target source (left ∪ right) := by
+  induction left using Finset.induction_on with
+  | empty => simp [sourceSubsetMatch]
+  | @insert tree left hnot ih =>
+      by_cases hright : tree ∈ right
+      · rw [Finset.insert_union, Finset.insert_eq_of_mem (Finset.mem_union_right left hright)]
+        simp only [sourceSubsetMatch, Finset.prod_insert hnot] at *
+        rw [mul_assoc, ih]
+        have hmem : tree ∈ left ∪ right := Finset.mem_union_right left hright
+        rw [Finset.prod_eq_mul_prod_sdiff_singleton_of_mem hmem, ← mul_assoc, sourceTreeMatch_mul_self]
+      · have hnotunion : tree ∉ left ∪ right := by simp only [Finset.mem_union, not_or]; exact ⟨hnot, hright⟩
+        simp only [sourceSubsetMatch, Finset.prod_insert hnot, Finset.insert_union,
+          Finset.prod_insert hnotunion] at *
+        rw [mul_assoc, ih]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/SubsetTargetExpectation.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/SubsetTargetExpectation.lean
new file mode 100644
index 000000000..6d8b4a473
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/SubsetTargetExpectation.lean
@@ -0,0 +1,65 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.SubsetTargetAssignment
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem sum_leaf_partial_product (required : Finset FtsTree) (weight : FtsTree → FtsLeaf → Nat) :
+    (∑ leaves : FtsTree → FtsLeaf, ∏ tree ∈ required, weight tree (leaves tree)) =
+      Fintype.card FtsLeaf ^ (Fintype.card FtsTree - required.card) * ∏ tree ∈ required, ∑ leaf : FtsLeaf, weight tree leaf := by
+  have hprod (leaves : FtsTree → FtsLeaf) := Fintype.prod_ite_mem required (fun tree => weight tree (leaves tree))
+  simp only [← hprod]
+  rw [← Fintype.prod_sum (fun tree leaf => if tree ∈ required then weight tree leaf else 1)]
+  have hsum (tree : FtsTree) : (∑ leaf : FtsLeaf, if tree ∈ required then weight tree leaf else 1) =
+      if tree ∈ required then ∑ leaf : FtsLeaf, weight tree leaf else Fintype.card FtsLeaf := by
+    split_ifs <;> simp only [Finset.sum_const, Finset.card_univ, smul_eq_mul, mul_one]
+  simp only [hsum]
+  rw [← Finset.prod_sdiff (Finset.subset_univ required)]
+  rw [Finset.prod_ite_of_true (fun tree ht => ht), Finset.prod_ite_of_false (fun tree ht => (Finset.mem_sdiff.mp ht).2)]
+  simp only [Finset.prod_const, Finset.card_sdiff_of_subset (Finset.subset_univ required), Finset.card_univ]
+
+theorem sourceSubsetMatch_index (target : FewTimeView) (required : Finset FtsTree) (hne : required.Nonempty)
+    (index : Index) (leaves : FtsTree → FtsLeaf) :
+    sourceSubsetMatch target (index, leaves) required =
+      if index = target.1 then ∏ tree ∈ required, (if leaves tree = target.2 tree then 1 else 0) else 0 := by
+  by_cases hi : index = target.1
+  · simp only [sourceSubsetMatch, sourceTreeMatch, hi, true_and, if_true]
+  · obtain ⟨tree, htree⟩ := hne
+    simp only [sourceSubsetMatch, sourceTreeMatch, hi, false_and, if_false]
+    exact Finset.prod_eq_zero htree rfl
+
+theorem sum_sourceSubsetMatch (target : FewTimeView) (required : Finset FtsTree) (hne : required.Nonempty) :
+    (∑ source : FewTimeView, sourceSubsetMatch target source required) =
+      Fintype.card FtsLeaf ^ (Fintype.card FtsTree - required.card) := by
+  rw [Fintype.sum_prod_type]
+  simp only [sourceSubsetMatch_index target required hne, Finset.sum_ite_irrel, Finset.sum_const_zero,
+    Finset.sum_ite_eq', Finset.mem_univ, if_true]
+  rw [sum_leaf_partial_product required (fun tree leaf => if leaf = target.2 tree then 1 else 0)]
+  simp only [Finset.sum_ite_eq', Finset.mem_univ, if_true, Finset.prod_const_one, mul_one]
+
+theorem expected_sourceSubsetMatch (target : FewTimeView) (required : Finset FtsTree) (hne : required.Nonempty) :
+    (∑' source, Pr[= source | ($ᵗ FewTimeView : ProbComp FewTimeView)] * (sourceSubsetMatch target source required : ENNReal)) =
+      (Fintype.card FtsLeaf ^ (Fintype.card FtsTree - required.card) : Nat) / (Fintype.card FewTimeView : ENNReal) := by
+  simp only [probOutput_uniformSample, tsum_fintype]
+  rw [← Finset.mul_sum, ← Nat.cast_sum, sum_sourceSubsetMatch target required hne]
+  exact mul_comm _ _
+
+theorem normalized_expected_sourceSubsetMatch (target : FewTimeView) (required : Finset FtsTree) (hne : required.Nonempty) :
+    (Fintype.card FtsLeaf ^ required.card : Nat) *
+      (∑' source, Pr[= source | ($ᵗ FewTimeView : ProbComp FewTimeView)] * (sourceSubsetMatch target source required : ENNReal)) =
+      (Fintype.card Index : ENNReal)⁻¹ := by
+  have hcard : Fintype.card FewTimeView = Fintype.card FtsLeaf ^ Fintype.card FtsTree * Fintype.card Index := by
+    simp only [FewTimeView, Fintype.card_prod, Fintype.card_fun]
+    exact mul_comm _ _
+  have hle : required.card ≤ Fintype.card FtsTree := Finset.card_le_univ required
+  have hexp : required.card + (Fintype.card FtsTree - required.card) = Fintype.card FtsTree := by omega
+  have hzero : ((Fintype.card FtsLeaf ^ Fintype.card FtsTree : Nat) : ENNReal) ≠ 0 :=
+    Nat.cast_ne_zero.mpr (pow_ne_zero _ (ne_of_gt (Fintype.card_pos)))
+  have hfinite : ((Fintype.card FtsLeaf ^ Fintype.card FtsTree : Nat) : ENNReal) ≠ ∞ := ENNReal.natCast_ne_top _
+  rw [expected_sourceSubsetMatch target required hne, div_eq_mul_inv, ← mul_assoc, ← Nat.cast_mul, ← pow_add, hexp, hcard,
+    Nat.cast_mul, ENNReal.mul_inv (Or.inl hzero) (Or.inl hfinite),
+    ← mul_assoc, ENNReal.mul_inv_cancel hzero hfinite, one_mul]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/TargetAssignmentCount.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/TargetAssignmentCount.lean
new file mode 100644
index 000000000..aeeed7e38
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/TargetAssignmentCount.lean
@@ -0,0 +1,22 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FewTimeProbability
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def targetTreeMatchCount {n : Nat} (views : Fin n → Option FewTimeView) (target : FewTimeView) (tree : FtsTree) : Nat :=
+  ∑ slot : Fin n, if ∃ view, views slot = some view ∧ view.1 = target.1 ∧ view.2 tree = target.2 tree then 1 else 0
+
+noncomputable def sourceTreeMatch (target source : FewTimeView) (tree : FtsTree) : Nat :=
+  if source.1 = target.1 ∧ source.2 tree = target.2 tree then 1 else 0
+
+theorem targetTreeMatchCount_pos_iff {n : Nat} (views : Fin n → Option FewTimeView) (target : FewTimeView) (tree : FtsTree) :
+    0 < targetTreeMatchCount views target tree ↔ ∃ slot view, views slot = some view ∧ view.1 = target.1 ∧ view.2 tree = target.2 tree := by
+  simp only [targetTreeMatchCount, Finset.sum_pos_iff, Finset.mem_univ, true_and]
+  apply exists_congr
+  intro slot
+  split_ifs <;> simp_all
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/TargetIndexEnvelope.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/TargetIndexEnvelope.lean
new file mode 100644
index 000000000..ebaefc4c2
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/TargetIndexEnvelope.lean
@@ -0,0 +1,71 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.TargetShapeCardinality
+import SphincsSecurity.Proof.Fts.TargetShapeContinuation
+namespace SphincsSecurity.Concrete
+
+open ENNReal
+
+noncomputable def targetIndexQuery (arrival : ENNReal) (moments : TargetIndexVector) (power degree : Nat) : ENNReal :=
+  moments power degree + arrival * targetIndexCacheLower moments power degree
+
+noncomputable def targetIndexSigning (uniform reuse : ENNReal) (moments : TargetIndexVector) (power degree : Nat) : ENNReal :=
+  moments power degree + uniform *
+    (targetIndexCacheLower moments power degree + targetIndexTreeLower moments power degree + targetIndexCacheLower (targetIndexTreeLower moments) power degree) +
+      reuse * targetIndexReuseStep moments power degree
+
+noncomputable def targetIndexEnvelope (uniform reuse arrival : ENNReal) (queries signings : Nat) (moments : TargetIndexVector) : TargetIndexVector :=
+  (targetIndexSigning uniform reuse)^[signings] ((targetIndexQuery arrival)^[queries] moments)
+
+theorem targetShapeQuery_lift (arrival : ENNReal) (moments : TargetIndexVector) :
+    targetShapeQuery arrival (liftTargetIndexVector moments) = liftTargetIndexVector (targetIndexQuery arrival moments) := by
+  funext groups remaining
+  simp only [targetShapeQuery, targetCacheLower_lift, liftTargetIndexVector, targetIndexQuery]
+
+theorem targetShapeSigning_lift (uniform reuse : ENNReal) (moments : TargetIndexVector)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining) :
+    targetShapeSigning uniform reuse (liftTargetIndexVector moments) groups remaining =
+      liftTargetIndexVector (targetIndexSigning uniform reuse moments) groups remaining := by
+  simp only [targetShapeSigning, targetTreeLower_lift, targetCacheLower_lift, targetReuseStep_lift moments groups remaining hvalid,
+    liftTargetIndexVector, targetIndexSigning]
+
+theorem targetShapeSigning_congr (uniform reuse : ENNReal) {f g : TargetShapeVector}
+    (heq : ∀ G R, TargetShapeValid G R → f G R = g G R)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining) :
+    targetShapeSigning uniform reuse f groups remaining = targetShapeSigning uniform reuse g groups remaining :=
+  le_antisymm (targetShapeSigning_mono uniform reuse (fun G R hv => (heq G R hv).le) groups remaining hvalid)
+    (targetShapeSigning_mono uniform reuse (fun G R hv => (heq G R hv).ge) groups remaining hvalid)
+
+theorem targetShapeEnvelope_congr (uniform reuse arrival : ENNReal) (queries signings : Nat) {f g : TargetShapeVector}
+    (heq : ∀ G R, TargetShapeValid G R → f G R = g G R)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining) :
+    targetShapeEnvelope uniform reuse arrival queries signings f groups remaining =
+      targetShapeEnvelope uniform reuse arrival queries signings g groups remaining :=
+  le_antisymm (targetShapeEnvelope_mono uniform reuse arrival queries signings (fun G R hv => (heq G R hv).le) groups remaining hvalid)
+    (targetShapeEnvelope_mono uniform reuse arrival queries signings (fun G R hv => (heq G R hv).ge) groups remaining hvalid)
+
+theorem targetShapeQuery_iterate_lift (arrival : ENNReal) (queries : Nat) (moments : TargetIndexVector) :
+    (targetShapeQuery arrival)^[queries] (liftTargetIndexVector moments) = liftTargetIndexVector ((targetIndexQuery arrival)^[queries] moments) := by
+  induction queries with
+  | zero => rfl
+  | succ queries ih => simp only [Function.iterate_succ_apply', ih, targetShapeQuery_lift]
+
+theorem targetShapeSigning_iterate_lift (uniform reuse : ENNReal) (signings : Nat) (moments : TargetIndexVector)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining) :
+    (targetShapeSigning uniform reuse)^[signings] (liftTargetIndexVector moments) groups remaining =
+      liftTargetIndexVector ((targetIndexSigning uniform reuse)^[signings] moments) groups remaining := by
+  induction signings generalizing groups remaining with
+  | zero => rfl
+  | succ signings ih =>
+      simp only [Function.iterate_succ_apply']
+      rw [targetShapeSigning_congr uniform reuse ih groups remaining hvalid]
+      exact targetShapeSigning_lift uniform reuse _ groups remaining hvalid
+
+theorem targetShapeEnvelope_lift (uniform reuse arrival : ENNReal) (queries signings : Nat) (moments : TargetIndexVector)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining) :
+    targetShapeEnvelope uniform reuse arrival queries signings (liftTargetIndexVector moments) groups remaining =
+      targetIndexEnvelope uniform reuse arrival queries signings moments groups.card remaining.card := by
+  unfold targetShapeEnvelope targetIndexEnvelope
+  rw [targetShapeQuery_iterate_lift]
+  exact targetShapeSigning_iterate_lift uniform reuse signings _ groups remaining hvalid
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/TargetMixedGrowthPolynomial.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/TargetMixedGrowthPolynomial.lean
new file mode 100644
index 000000000..fdf3e5fb4
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/TargetMixedGrowthPolynomial.lean
@@ -0,0 +1,91 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.NormalizedTargetMatches
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem normalizedSourceSubsetMatch_mul (target source : FewTimeView) (left right : Finset FtsTree)
+    (hdisjoint : Disjoint left right) :
+    normalizedSourceSubsetMatch target source left * normalizedSourceSubsetMatch target source right =
+      normalizedSourceSubsetMatch target source (left ∪ right) := by
+  unfold normalizedSourceSubsetMatch
+  rw [Finset.card_union_of_disjoint hdisjoint, pow_add, Nat.cast_mul, ← sourceSubsetMatch_mul, Nat.cast_mul]
+  ring
+
+theorem normalizedSourceSubsetMatch_singletons (target source : FewTimeView) (required : Finset FtsTree) :
+    (∏ tree ∈ required, normalizedSourceSubsetMatch target source {tree}) = normalizedSourceSubsetMatch target source required := by
+  simp only [normalizedSourceSubsetMatch, sourceSubsetMatch, Finset.card_singleton, pow_one,
+    Finset.prod_singleton, Finset.prod_mul_distrib, Finset.prod_const, Nat.cast_pow, Nat.cast_prod]
+
+noncomputable def targetCacheArrivalPolynomial (cached : Fin m → ENNReal) (groups : Fin m → Finset FtsTree)
+    (target source : FewTimeView) : ENNReal :=
+  ∑ selected ∈ (Finset.univ : Finset (Fin m)).powerset.erase ∅,
+    (∏ slot ∈ selected, normalizedSourceSubsetMatch target source (groups slot)) *
+      ∏ slot ∈ (Finset.univ : Finset (Fin m)) \ selected, cached slot
+
+theorem targetCacheProduct_add_arrival (cached : Fin m → ENNReal) (groups : Fin m → Finset FtsTree)
+    (target source : FewTimeView) :
+    (∏ slot : Fin m, cached slot) + targetCacheArrivalPolynomial cached groups target source =
+      ∏ slot : Fin m, (cached slot + normalizedSourceSubsetMatch target source (groups slot)) := by
+  rw [show (∏ slot : Fin m, (cached slot + normalizedSourceSubsetMatch target source (groups slot))) =
+    ∏ slot : Fin m, (normalizedSourceSubsetMatch target source (groups slot) + cached slot) by simp only [add_comm]]
+  rw [Finset.prod_add, ← Finset.add_sum_erase _ _ (Finset.empty_mem_powerset _)]
+  simp only [Finset.prod_empty, Finset.sdiff_empty, one_mul, targetCacheArrivalPolynomial]
+
+theorem targetLogProduct_insert_expansion (logged : FtsTree → ENNReal) (required : Finset FtsTree) (target source : FewTimeView) :
+    (∏ tree ∈ required, (logged tree + normalizedSourceSubsetMatch target source {tree})) =
+      ∑ selected ∈ required.powerset, normalizedSourceSubsetMatch target source selected *
+        ∏ tree ∈ required \ selected, logged tree := by
+  rw [show (∏ tree ∈ required, (logged tree + normalizedSourceSubsetMatch target source {tree})) =
+    ∏ tree ∈ required, (normalizedSourceSubsetMatch target source {tree} + logged tree) by simp only [add_comm]]
+  rw [Finset.prod_add]
+  simp only [normalizedSourceSubsetMatch_singletons]
+
+noncomputable def targetMixedGrowthPolynomial (cached : Fin m → ENNReal) (logged : FtsTree → ENNReal)
+    (groups : Fin m → Finset FtsTree) (required : Finset FtsTree) (target source : FewTimeView) : ENNReal :=
+  targetCacheArrivalPolynomial cached groups target source *
+    ∏ tree ∈ required, (logged tree + normalizedSourceSubsetMatch target source {tree})
+
+theorem expected_targetMixedGrowthPolynomial (cached : Fin m → ENNReal) (logged : FtsTree → ENNReal)
+    (groups : Fin m → Finset FtsTree) (required : Finset FtsTree) (target : FewTimeView)
+    (hgroups : ∀ slot, (groups slot).Nonempty) (hdisjoint : Pairwise (fun i j => Disjoint (groups i) (groups j)))
+    (hremaining : ∀ slot, Disjoint (groups slot) required) :
+    (∑' source, Pr[= source | ($ᵗ FewTimeView : ProbComp FewTimeView)] *
+      targetMixedGrowthPolynomial cached logged groups required target source) =
+      (Fintype.card Index : ENNReal)⁻¹ *
+        ∑ selected ∈ (Finset.univ : Finset (Fin m)).powerset.erase ∅,
+          ∑ trees ∈ required.powerset,
+            (∏ slot ∈ (Finset.univ : Finset (Fin m)) \ selected, cached slot) *
+              ∏ tree ∈ required \ trees, logged tree := by
+  simp only [targetMixedGrowthPolynomial, targetCacheArrivalPolynomial, targetLogProduct_insert_expansion]
+  simp only [Finset.sum_mul]
+  simp only [Finset.mul_sum]
+  rw [Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)]
+  apply Finset.sum_congr rfl
+  intro selected hselected
+  rw [Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)]
+  apply Finset.sum_congr rfl
+  intro trees htrees
+  have hselectedNonempty := Finset.nonempty_iff_ne_empty.mpr (Finset.mem_erase.mp hselected).1
+  have hpair : (selected : Set (Fin m)).PairwiseDisjoint groups := fun i _ j _ hij => hdisjoint hij
+  have hsep : Disjoint (selected.biUnion groups) trees := by
+    rw [Finset.disjoint_biUnion_left]
+    intro slot _
+    exact (hremaining slot).mono_right (Finset.mem_powerset.mp htrees)
+  have hpoint (source : FewTimeView) :
+      (∏ slot ∈ selected, normalizedSourceSubsetMatch target source (groups slot)) *
+        (∏ slot ∈ (Finset.univ : Finset (Fin m)) \ selected, cached slot) *
+          (normalizedSourceSubsetMatch target source trees * ∏ tree ∈ required \ trees, logged tree) =
+      normalizedSourceSubsetMatch target source (selected.biUnion groups ∪ trees) *
+        ((∏ slot ∈ (Finset.univ : Finset (Fin m)) \ selected, cached slot) * ∏ tree ∈ required \ trees, logged tree) := by
+    rw [normalizedSourceSubsetMatch_prod target source groups selected hpair, ← normalizedSourceSubsetMatch_mul target source _ _ hsep]
+    ring
+  simp only [hpoint, ← mul_assoc, ENNReal.tsum_mul_right]
+  obtain ⟨slot, hslot⟩ := hselectedNonempty
+  obtain ⟨tree, htree⟩ := hgroups slot
+  rw [expected_normalizedSourceSubsetMatch target (selected.biUnion groups ∪ trees)
+    ⟨tree, Finset.mem_union_left _ (Finset.mem_biUnion.mpr ⟨slot, hslot, htree⟩)⟩]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/TargetMomentShapes.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/TargetMomentShapes.lean
new file mode 100644
index 000000000..9e6bc26e3
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/TargetMomentShapes.lean
@@ -0,0 +1,47 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Statement
+
+namespace SphincsSecurity.Concrete
+
+attribute [local instance] Classical.propDecidable
+
+structure TargetShapeValid (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) : Prop where
+  nonempty : ∀ group ∈ groups, group.Nonempty
+  disjoint : ∀ first ∈ groups, ∀ second ∈ groups, first ≠ second → Disjoint first second
+  remaining : ∀ group ∈ groups, Disjoint group remaining
+
+theorem TargetShapeValid.subsets {groups kept : Finset (Finset FtsTree)} {remaining trees : Finset FtsTree}
+    (hvalid : TargetShapeValid groups remaining) (hgroups : kept ⊆ groups) (htrees : trees ⊆ remaining) :
+    TargetShapeValid kept trees where
+  nonempty group hgroup := hvalid.nonempty group (hgroups hgroup)
+  disjoint first hfirst second hsecond hne := hvalid.disjoint first (hgroups hfirst) second (hgroups hsecond) hne
+  remaining group hgroup := (hvalid.remaining group (hgroups hgroup)).mono_right htrees
+
+theorem TargetShapeValid.new_group {groups : Finset (Finset FtsTree)} {remaining selected : Finset FtsTree}
+    (hvalid : TargetShapeValid groups remaining) (hselected : selected.Nonempty) (hsub : selected ⊆ remaining) : selected ∉ groups := by
+  intro hmem
+  obtain ⟨tree, htree⟩ := hselected
+  exact Finset.disjoint_left.mp (hvalid.remaining selected hmem) htree (hsub htree)
+
+theorem TargetShapeValid.reuse {groups : Finset (Finset FtsTree)} {remaining selected : Finset FtsTree}
+    (hvalid : TargetShapeValid groups remaining) (hselected : selected.Nonempty) (hsub : selected ⊆ remaining) :
+    TargetShapeValid (insert selected groups) (remaining \ selected) := by
+  constructor
+  · intro group hgroup
+    rcases Finset.mem_insert.mp hgroup with rfl | hgroup
+    · exact hselected
+    · exact hvalid.nonempty group hgroup
+  · intro first hfirst second hsecond hne
+    rcases Finset.mem_insert.mp hfirst with rfl | hfirstOld
+    · rcases Finset.mem_insert.mp hsecond with rfl | hsecond
+      · exact (hne rfl).elim
+      · exact ((hvalid.remaining second hsecond).mono_right hsub).symm
+    · rcases Finset.mem_insert.mp hsecond with rfl | hsecond
+      · exact (hvalid.remaining first hfirstOld).mono_right hsub
+      · exact hvalid.disjoint first hfirstOld second hsecond hne
+  · intro group hgroup
+    rcases Finset.mem_insert.mp hgroup with rfl | hgroup
+    · exact Finset.disjoint_left.mpr (fun tree htree hrest => (Finset.mem_sdiff.mp hrest).2 htree)
+    · exact (hvalid.remaining group hgroup).mono_right Finset.sdiff_subset
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/TargetShapeBlocks.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/TargetShapeBlocks.lean
new file mode 100644
index 000000000..c8833f9eb
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/TargetShapeBlocks.lean
@@ -0,0 +1,83 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.ConcreteTargetShapeSigning
+import SphincsSecurity.Proof.Fts.TargetSourceMultiplicity
+import SphincsSecurity.Proof.Fts.WeightedTargetGroups
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+abbrev TargetShapeSlot (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) := groups ⊕ remaining
+
+def targetShapeSlotGroup (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) : TargetShapeSlot groups remaining → Finset FtsTree
+  | .inl group => group.val
+  | .inr tree => {tree.val}
+
+theorem targetShapeSlotGroup_nonempty (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree)
+    (hvalid : TargetShapeValid groups remaining) (slot : TargetShapeSlot groups remaining) : (targetShapeSlotGroup groups remaining slot).Nonempty := by
+  cases slot with
+  | inl group => exact hvalid.nonempty group.val group.property
+  | inr tree => exact Finset.singleton_nonempty tree.val
+
+theorem targetShapeSlotGroup_disjoint (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree)
+    (hvalid : TargetShapeValid groups remaining) : Pairwise (fun i j => Disjoint (targetShapeSlotGroup groups remaining i) (targetShapeSlotGroup groups remaining j)) := by
+  intro first second hne
+  cases first with
+  | inl first =>
+      cases second with
+      | inl second =>
+          exact hvalid.disjoint first.val first.property second.val second.property
+            (fun heq => hne (congrArg Sum.inl (Subtype.ext heq)))
+      | inr second => exact (hvalid.remaining first.val first.property).mono_right (Finset.singleton_subset_iff.mpr second.property)
+  | inr first =>
+      cases second with
+      | inl second => exact ((hvalid.remaining second.val second.property).mono_right (Finset.singleton_subset_iff.mpr first.property)).symm
+      | inr second =>
+          apply Finset.disjoint_left.mpr
+          intro tree hfirst hsecond
+          have heq : first.val = second.val := (Finset.mem_singleton.mp hfirst).symm.trans (Finset.mem_singleton.mp hsecond)
+          exact hne (congrArg Sum.inr (Subtype.ext heq))
+
+noncomputable def targetShapeSlotWeight (key : SecretKey) (cache : QueryCache HashSpec) (log : QueryLog SigningSpec) (payload : HashInput)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) : TargetShapeSlot groups remaining → FewTimeView → ENNReal
+  | .inl _ => excludedCacheSourceCount key.parameter cache (tweakableHashInput key.parameter .message payload)
+  | .inr _ => optionalSourceCount (eligibleSigningViews (FtsProbeSimulation.messageAnswers key.parameter cache) key.root payload log)
+
+theorem targetShapeMoments_eq_weightedGroups (key : SecretKey) (cache : QueryCache HashSpec) (log : QueryLog SigningSpec)
+    (payload : HashInput) (target : FewTimeView) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) :
+    targetShapeMoments key cache log payload target groups remaining =
+      ∏ slot : TargetShapeSlot groups remaining, ∑ source : FewTimeView,
+        targetShapeSlotWeight key cache log payload groups remaining slot source *
+          normalizedSourceSubsetMatch target source (targetShapeSlotGroup groups remaining slot) := by
+  simp only [Fintype.prod_sum_type, targetShapeSlotWeight, targetShapeSlotGroup,
+    ← normalizedCachedTargetSubsetMatch_eq_sourceCount, ← normalizedTargetTreeMatchCount_eq_sourceCount,
+    Finset.prod_coe_sort, targetShapeMoments, normalizedTargetLogProduct, normalizedTargetLogMatch]
+  rw [Finset.prod_coe_sort remaining (fun tree => (Fintype.card FtsLeaf : ENNReal) *
+    (targetTreeMatchCount (eligibleSigningViews (FtsProbeSimulation.messageAnswers key.parameter cache) key.root payload log) target tree : ENNReal))]
+
+noncomputable def excludedCacheIndexCount (parameter : PublicParameter) (cache : QueryCache HashSpec) (targetInput : HashInput) (index : Index) : ENNReal :=
+  cacheMessageWeight parameter (fun input source => if input = targetInput then 0 else if source.1 = index then 1 else 0) cache
+
+theorem excludedCacheSourceCount_index (parameter : PublicParameter) (cache : QueryCache HashSpec) (targetInput : HashInput) (index : Index) :
+    (∑ source : FewTimeView, if source.1 = index then excludedCacheSourceCount parameter cache targetInput source else 0) =
+      excludedCacheIndexCount parameter cache targetInput index := by
+  have heq (source : FewTimeView) : (if source.1 = index then excludedCacheSourceCount parameter cache targetInput source else 0) =
+      excludedCacheSourceCount parameter cache targetInput source * (if source.1 = index then 1 else 0) := by
+    split_ifs <;> simp only [mul_one, mul_zero]
+  simp only [heq, excludedCacheSourceCount_weight, excludedCacheIndexCount]
+
+theorem expected_targetShapeMoments (key : SecretKey) (cache : QueryCache HashSpec) (log : QueryLog SigningSpec)
+    (payload : HashInput) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining) :
+    (∑' target, Pr[= target | ($ᵗ FewTimeView : ProbComp FewTimeView)] * targetShapeMoments key cache log payload target groups remaining) =
+      (Fintype.card Index : ENNReal)⁻¹ * ∑ index : Index,
+        excludedCacheIndexCount key.parameter cache (tweakableHashInput key.parameter .message payload) index ^ groups.card *
+          ((signingSlotsAtIndex (eligibleSigningViews (FtsProbeSimulation.messageAnswers key.parameter cache) key.root payload log) index).card : ENNReal) ^ remaining.card := by
+  classical
+  simp only [targetShapeMoments_eq_weightedGroups]
+  rw [expected_weighted_targetGroups _ (targetShapeSlotGroup_nonempty groups remaining hvalid)
+    (targetShapeSlotGroup_disjoint groups remaining hvalid)]
+  simp only [Fintype.prod_sum_type, targetShapeSlotWeight, excludedCacheSourceCount_index, optionalSourceCount_index,
+    Finset.prod_const, Finset.card_univ, Fintype.card_coe]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/TargetShapeCardinality.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/TargetShapeCardinality.lean
new file mode 100644
index 000000000..12144c149
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/TargetShapeCardinality.lean
@@ -0,0 +1,64 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.TargetShapeOperators
+import SphincsSecurity.Proof.Fts.TargetShapeReindex
+namespace SphincsSecurity.Concrete
+
+open ENNReal
+attribute [local instance] Classical.propDecidable
+
+theorem sum_proper_subsets_card {α : Type} [DecidableEq α] (s : Finset α) (f : Nat → ENNReal) :
+    (∑ kept ∈ s.powerset.erase s, f kept.card) = ∑ degree ∈ Finset.range s.card, (s.card.choose degree : ENNReal) * f degree := by
+  have hindicator : (∑ kept ∈ s.powerset.erase s, f kept.card) =
+      ∑ kept ∈ s.powerset, if kept.card = s.card then 0 else f kept.card := by
+    rw [← Finset.filter_ne', Finset.sum_filter]
+    apply Finset.sum_congr rfl
+    intro kept hkept
+    have heq : kept.card = s.card ↔ kept = s := by
+      constructor
+      · intro hcard
+        exact Finset.eq_of_subset_of_card_le (Finset.mem_powerset.mp hkept) hcard.ge
+      · rintro rfl; rfl
+    by_cases h : kept = s <;> simp only [heq, h, ne_eq, not_true_eq_false, not_false_eq_true, if_true, if_false]
+  rw [hindicator, Finset.sum_powerset_apply_card (fun degree => if degree = s.card then 0 else f degree), Finset.sum_range_succ]
+  simp only [if_true, smul_zero, add_zero, nsmul_eq_mul]
+  apply Finset.sum_congr rfl
+  intro degree hdegree
+  rw [if_neg (Nat.ne_of_lt (Finset.mem_range.mp hdegree))]
+
+abbrev TargetIndexVector := Nat → Nat → ENNReal
+
+def liftTargetIndexVector (moments : TargetIndexVector) : TargetShapeVector := fun groups remaining => moments groups.card remaining.card
+
+noncomputable def targetIndexCacheLower (moments : TargetIndexVector) (power degree : Nat) : ENNReal :=
+  ∑ lower ∈ Finset.range power, (power.choose lower : ENNReal) * moments lower degree
+
+noncomputable def targetIndexTreeLower (moments : TargetIndexVector) (power degree : Nat) : ENNReal :=
+  ∑ lower ∈ Finset.range degree, (degree.choose lower : ENNReal) * moments power lower
+
+noncomputable def targetIndexReuseStep (moments : TargetIndexVector) (power degree : Nat) : ENNReal :=
+  targetIndexTreeLower moments (power + 1) degree
+
+theorem targetCacheLower_lift (moments : TargetIndexVector) :
+    targetCacheLower (liftTargetIndexVector moments) = liftTargetIndexVector (targetIndexCacheLower moments) := by
+  funext groups remaining
+  exact sum_proper_subsets_card groups (fun power => moments power remaining.card)
+
+theorem targetTreeLower_lift (moments : TargetIndexVector) :
+    targetTreeLower (liftTargetIndexVector moments) = liftTargetIndexVector (targetIndexTreeLower moments) := by
+  funext groups remaining
+  unfold targetTreeLower liftTargetIndexVector targetIndexTreeLower
+  rw [sum_nonempty_sdiff_eq_proper remaining (fun kept => moments groups.card kept.card)]
+  exact sum_proper_subsets_card remaining (moments groups.card)
+
+theorem targetReuseStep_lift (moments : TargetIndexVector) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree)
+    (hvalid : TargetShapeValid groups remaining) :
+    targetReuseStep (liftTargetIndexVector moments) groups remaining = liftTargetIndexVector (targetIndexReuseStep moments) groups remaining := by
+  unfold targetReuseStep liftTargetIndexVector
+  have hcard (selected : Finset FtsTree) (hselected : selected ∈ remaining.powerset.erase ∅) : (insert selected groups).card = groups.card + 1 :=
+    Finset.card_insert_of_notMem (hvalid.new_group (Finset.nonempty_iff_ne_empty.mpr (Finset.mem_erase.mp hselected).1)
+      (Finset.mem_powerset.mp (Finset.mem_erase.mp hselected).2))
+  rw [Finset.sum_congr rfl (fun selected hselected => congrArg (fun power => moments power (remaining \ selected).card) (hcard selected hselected))]
+  rw [sum_nonempty_sdiff_eq_proper remaining (fun kept => moments (groups.card + 1) kept.card)]
+  exact sum_proper_subsets_card remaining (moments (groups.card + 1))
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/TargetShapeContinuation.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/TargetShapeContinuation.lean
new file mode 100644
index 000000000..ab87c1094
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/TargetShapeContinuation.lean
@@ -0,0 +1,54 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.TargetShapeEnvelope
+namespace SphincsSecurity.Concrete
+
+open ENNReal
+
+theorem targetShapeQuery_iterate_mono (arrival : ENNReal) (queries : Nat) {f g : TargetShapeVector} (h : TargetShapeLE f g) :
+    TargetShapeLE ((targetShapeQuery arrival)^[queries] f) ((targetShapeQuery arrival)^[queries] g) := by
+  induction queries with
+  | zero => exact h
+  | succ queries ih =>
+      simp only [Function.iterate_succ_apply']
+      exact targetShapeQuery_mono arrival ih
+
+theorem targetShapeEnvelope_mono (uniform reuse arrival : ENNReal) (queries signings : Nat)
+    {f g : TargetShapeVector} (h : TargetShapeLE f g) :
+    TargetShapeLE (targetShapeEnvelope uniform reuse arrival queries signings f) (targetShapeEnvelope uniform reuse arrival queries signings g) :=
+  targetShapeSigning_iterate_mono uniform reuse signings (targetShapeQuery_iterate_mono arrival queries h)
+
+theorem targetShapeEnvelope_queries_mono (uniform reuse arrival : ENNReal) (signings : Nat) (f : TargetShapeVector)
+    {small large : Nat} (h : small ≤ large) :
+    TargetShapeLE (targetShapeEnvelope uniform reuse arrival small signings f) (targetShapeEnvelope uniform reuse arrival large signings f) := by
+  apply targetShapeSigning_iterate_mono
+  intro G R _
+  exact Function.monotone_iterate_of_id_le (show ∀ f : TargetShapeVector, f ≤ targetShapeQuery arrival f from fun _ _ _ => le_self_add) h f G R
+
+theorem le_targetShapeEnvelope (uniform reuse arrival : ENNReal) (queries signings : Nat) (f : TargetShapeVector) :
+    f ≤ targetShapeEnvelope uniform reuse arrival queries signings f :=
+  (Function.id_le_iterate_of_id_le (show ∀ f : TargetShapeVector, f ≤ targetShapeQuery arrival f from fun _ _ _ => le_self_add) queries f).trans
+    (Function.id_le_iterate_of_id_le (show ∀ f : TargetShapeVector, f ≤ targetShapeSigning uniform reuse f from
+      fun _ _ _ => le_self_add.trans le_self_add) signings _)
+
+theorem targetShapeEnvelope_query (uniform reuse arrival : ENNReal) (queries signings : Nat) (f : TargetShapeVector) :
+    targetShapeEnvelope uniform reuse arrival queries signings (targetShapeQuery arrival f) =
+      targetShapeEnvelope uniform reuse arrival (queries + 1) signings f := by
+  simp only [targetShapeEnvelope, Function.iterate_succ_apply]
+
+theorem targetShapeQuery_iterate_signing_le (uniform reuse arrival : ENNReal) (queries : Nat) (f : TargetShapeVector) :
+    TargetShapeLE ((targetShapeQuery arrival)^[queries] (targetShapeSigning uniform reuse f))
+      (targetShapeSigning uniform reuse ((targetShapeQuery arrival)^[queries] f)) := by
+  induction queries with
+  | zero => exact TargetShapeLE.refl _
+  | succ queries ih =>
+      simp only [Function.iterate_succ_apply']
+      exact (targetShapeQuery_mono arrival ih).trans (targetShapeQuery_signing_le uniform reuse arrival _)
+
+theorem targetShapeEnvelope_signing_le (uniform reuse arrival : ENNReal) (queries signings : Nat) (f : TargetShapeVector) :
+    TargetShapeLE (targetShapeEnvelope uniform reuse arrival queries signings (targetShapeSigning uniform reuse f))
+      (targetShapeEnvelope uniform reuse arrival queries (signings + 1) f) := by
+  unfold targetShapeEnvelope
+  rw [Function.iterate_succ_apply]
+  exact targetShapeSigning_iterate_mono uniform reuse signings (targetShapeQuery_iterate_signing_le uniform reuse arrival queries f)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/TargetShapeEnvelope.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/TargetShapeEnvelope.lean
new file mode 100644
index 000000000..879ee5be5
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/TargetShapeEnvelope.lean
@@ -0,0 +1,85 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.TargetShapeOperators
+namespace SphincsSecurity.Concrete
+
+open ENNReal
+
+noncomputable def targetShapeQuery (arrival : ENNReal) (f : TargetShapeVector) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) : ENNReal :=
+  f groups remaining + arrival * targetCacheLower f groups remaining
+
+noncomputable def targetShapeSigning (uniform reuse : ENNReal) (f : TargetShapeVector) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) : ENNReal :=
+  f groups remaining + uniform *
+    (targetCacheLower f groups remaining + targetTreeLower f groups remaining + targetCacheLower (targetTreeLower f) groups remaining) +
+      reuse * targetReuseStep f groups remaining
+
+def TargetShapeLE (f g : TargetShapeVector) : Prop := ∀ groups remaining, TargetShapeValid groups remaining → f groups remaining ≤ g groups remaining
+
+theorem TargetShapeLE.refl (f : TargetShapeVector) : TargetShapeLE f f := fun _ _ _ => le_rfl
+
+theorem TargetShapeLE.trans {f g h : TargetShapeVector} (hfg : TargetShapeLE f g) (hgh : TargetShapeLE g h) : TargetShapeLE f h :=
+  fun G R hv => (hfg G R hv).trans (hgh G R hv)
+
+theorem targetCacheLower_shape_mono {f g : TargetShapeVector} (h : TargetShapeLE f g) : TargetShapeLE (targetCacheLower f) (targetCacheLower g) := by
+  intro groups remaining hvalid
+  exact Finset.sum_le_sum (fun kept hkept => h kept remaining
+    (hvalid.subsets (Finset.mem_powerset.mp (Finset.mem_erase.mp hkept).2) (Finset.Subset.refl _)))
+
+theorem targetTreeLower_shape_mono {f g : TargetShapeVector} (h : TargetShapeLE f g) : TargetShapeLE (targetTreeLower f) (targetTreeLower g) := by
+  intro groups remaining hvalid
+  exact Finset.sum_le_sum (fun _ _ => h _ _ (hvalid.subsets (Finset.Subset.refl _) Finset.sdiff_subset))
+
+theorem targetReuseStep_shape_mono {f g : TargetShapeVector} (h : TargetShapeLE f g) : TargetShapeLE (targetReuseStep f) (targetReuseStep g) := by
+  intro groups remaining hvalid
+  apply Finset.sum_le_sum
+  intro selected hselected
+  exact h _ _ (hvalid.reuse
+    (Finset.nonempty_iff_ne_empty.mpr (Finset.mem_erase.mp hselected).1)
+    (Finset.mem_powerset.mp (Finset.mem_erase.mp hselected).2))
+
+theorem targetShapeQuery_mono (arrival : ENNReal) {f g : TargetShapeVector} (h : TargetShapeLE f g) : TargetShapeLE (targetShapeQuery arrival f) (targetShapeQuery arrival g) := by
+  intro groups remaining hvalid
+  exact add_le_add (h groups remaining hvalid) (mul_le_mul' le_rfl (targetCacheLower_shape_mono h groups remaining hvalid))
+
+theorem targetShapeSigning_mono (uniform reuse : ENNReal) {f g : TargetShapeVector} (h : TargetShapeLE f g) :
+    TargetShapeLE (targetShapeSigning uniform reuse f) (targetShapeSigning uniform reuse g) := by
+  intro groups remaining hvalid
+  exact add_le_add (add_le_add (h groups remaining hvalid) (mul_le_mul' le_rfl
+    (add_le_add (add_le_add (targetCacheLower_shape_mono h groups remaining hvalid) (targetTreeLower_shape_mono h groups remaining hvalid))
+      (targetCacheLower_shape_mono (targetTreeLower_shape_mono h) groups remaining hvalid))))
+    (mul_le_mul' le_rfl (targetReuseStep_shape_mono h groups remaining hvalid))
+
+theorem targetShapeSigning_query_commute (uniform reuse arrival : ENNReal) (f : TargetShapeVector)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining) :
+    targetShapeSigning uniform reuse (targetShapeQuery arrival f) groups remaining =
+      targetShapeQuery arrival (targetShapeSigning uniform reuse f) groups remaining +
+        arrival * reuse * (targetTreeLower f groups remaining + targetCacheLower (targetTreeLower f) groups remaining) := by
+  have htree : targetTreeLower (targetShapeQuery arrival f) = fun G R =>
+      targetTreeLower f G R + arrival * targetCacheLower (targetTreeLower f) G R := by
+    funext G R
+    change targetTreeLower (fun G R => f G R + arrival * targetCacheLower f G R) G R = _
+    rw [targetTreeLower_add, targetTreeLower_mul, ← targetCacheLower_tree_commute]
+  unfold targetShapeSigning
+  rw [htree]
+  unfold targetShapeQuery
+  simp only [targetCacheLower_add, targetCacheLower_mul, targetReuseStep_add, targetReuseStep_mul]
+  rw [targetReuse_cache_commute f groups remaining hvalid]
+  ring
+
+theorem targetShapeQuery_signing_le (uniform reuse arrival : ENNReal) (f : TargetShapeVector) :
+    TargetShapeLE (targetShapeQuery arrival (targetShapeSigning uniform reuse f)) (targetShapeSigning uniform reuse (targetShapeQuery arrival f)) := by
+  intro groups remaining hvalid
+  rw [targetShapeSigning_query_commute uniform reuse arrival f groups remaining hvalid]
+  exact le_self_add
+
+noncomputable def targetShapeEnvelope (uniform reuse arrival : ENNReal) (queries signings : Nat) (f : TargetShapeVector) : TargetShapeVector :=
+  (targetShapeSigning uniform reuse)^[signings] ((targetShapeQuery arrival)^[queries] f)
+
+theorem targetShapeSigning_iterate_mono (uniform reuse : ENNReal) (signings : Nat) {f g : TargetShapeVector} (h : TargetShapeLE f g) :
+    TargetShapeLE ((targetShapeSigning uniform reuse)^[signings] f) ((targetShapeSigning uniform reuse)^[signings] g) := by
+  induction signings with
+  | zero => exact h
+  | succ signings ih =>
+      simp only [Function.iterate_succ_apply']
+      exact targetShapeSigning_mono uniform reuse ih
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/TargetShapeExpectation.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/TargetShapeExpectation.lean
new file mode 100644
index 000000000..5fc3d4fb6
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/TargetShapeExpectation.lean
@@ -0,0 +1,115 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.TargetShapeEnvelope
+namespace SphincsSecurity.Concrete
+
+open ENNReal
+
+theorem targetCacheLower_tsum {α : Type} (moments : α → TargetShapeVector) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) :
+    targetCacheLower (fun G R => ∑' result, moments result G R) groups remaining =
+      ∑' result, targetCacheLower (moments result) groups remaining := by
+  unfold targetCacheLower
+  exact (Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)).symm
+
+theorem targetTreeLower_tsum {α : Type} (moments : α → TargetShapeVector) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) :
+    targetTreeLower (fun G R => ∑' result, moments result G R) groups remaining =
+      ∑' result, targetTreeLower (moments result) groups remaining := by
+  unfold targetTreeLower
+  exact (Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)).symm
+
+theorem targetReuseStep_tsum {α : Type} (moments : α → TargetShapeVector) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) :
+    targetReuseStep (fun G R => ∑' result, moments result G R) groups remaining =
+      ∑' result, targetReuseStep (moments result) groups remaining := by
+  unfold targetReuseStep
+  exact (Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)).symm
+
+theorem targetShapeQuery_tsum {α : Type} (arrival : ENNReal) (moments : α → TargetShapeVector) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) :
+    targetShapeQuery arrival (fun G R => ∑' result, moments result G R) groups remaining =
+      ∑' result, targetShapeQuery arrival (moments result) groups remaining := by
+  simp only [targetShapeQuery, targetCacheLower_tsum, ENNReal.tsum_mul_left, ENNReal.tsum_add]
+
+theorem targetShapeSigning_tsum {α : Type} (uniform reuse : ENNReal) (moments : α → TargetShapeVector) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) :
+    targetShapeSigning uniform reuse (fun G R => ∑' result, moments result G R) groups remaining =
+      ∑' result, targetShapeSigning uniform reuse (moments result) groups remaining := by
+  have htree : targetTreeLower (fun G R => ∑' result, moments result G R) =
+      fun G R => ∑' result, targetTreeLower (moments result) G R := by
+    funext G R
+    exact targetTreeLower_tsum moments G R
+  simp only [targetShapeSigning, htree, targetCacheLower_tsum, targetReuseStep_tsum, ENNReal.tsum_mul_left, ENNReal.tsum_add]
+
+theorem targetShapeQuery_mul (arrival scalar : ENNReal) (moments : TargetShapeVector) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) :
+    targetShapeQuery arrival (fun G R => scalar * moments G R) groups remaining =
+      scalar * targetShapeQuery arrival moments groups remaining := by
+  simp only [targetShapeQuery, targetCacheLower_mul]
+  ring
+
+theorem targetShapeSigning_mul (uniform reuse scalar : ENNReal) (moments : TargetShapeVector) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) :
+    targetShapeSigning uniform reuse (fun G R => scalar * moments G R) groups remaining =
+      scalar * targetShapeSigning uniform reuse moments groups remaining := by
+  have htree : targetTreeLower (fun G R => scalar * moments G R) = fun G R => scalar * targetTreeLower moments G R := by
+    funext G R
+    exact targetTreeLower_mul scalar moments G R
+  simp only [targetShapeSigning, htree, targetCacheLower_mul, targetReuseStep_mul]
+  ring
+
+theorem targetShapeEnvelope_tsum {α : Type} (uniform reuse arrival : ENNReal) (queries signatures : Nat)
+    (moments : α → TargetShapeVector) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) :
+    targetShapeEnvelope uniform reuse arrival queries signatures (fun G R => ∑' result, moments result G R) groups remaining =
+      ∑' result, targetShapeEnvelope uniform reuse arrival queries signatures (moments result) groups remaining := by
+  have hquery (count : Nat) : (targetShapeQuery arrival)^[count] (fun G R => ∑' result, moments result G R) =
+      fun G R => ∑' result, (targetShapeQuery arrival)^[count] (moments result) G R := by
+    induction count with
+    | zero => rfl
+    | succ count ih =>
+        simp only [Function.iterate_succ_apply', ih]
+        funext G R
+        exact targetShapeQuery_tsum arrival _ G R
+  unfold targetShapeEnvelope
+  rw [hquery]
+  induction signatures generalizing groups remaining with
+  | zero => rfl
+  | succ signatures ih =>
+      simp only [Function.iterate_succ_apply']
+      have hsign : (targetShapeSigning uniform reuse)^[signatures]
+          (fun G R => ∑' result, (targetShapeQuery arrival)^[queries] (moments result) G R) =
+          fun G R => ∑' result, (targetShapeSigning uniform reuse)^[signatures] ((targetShapeQuery arrival)^[queries] (moments result)) G R := by
+        funext G R
+        exact ih G R
+      rw [hsign]
+      exact targetShapeSigning_tsum uniform reuse _ groups remaining
+
+theorem targetShapeEnvelope_mul (uniform reuse arrival scalar : ENNReal) (queries signatures : Nat)
+    (moments : TargetShapeVector) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) :
+    targetShapeEnvelope uniform reuse arrival queries signatures (fun G R => scalar * moments G R) groups remaining =
+      scalar * targetShapeEnvelope uniform reuse arrival queries signatures moments groups remaining := by
+  have hquery (count : Nat) : (targetShapeQuery arrival)^[count] (fun G R => scalar * moments G R) =
+      fun G R => scalar * (targetShapeQuery arrival)^[count] moments G R := by
+    induction count with
+    | zero => rfl
+    | succ count ih =>
+        simp only [Function.iterate_succ_apply', ih]
+        funext G R
+        exact targetShapeQuery_mul arrival scalar _ G R
+  unfold targetShapeEnvelope
+  rw [hquery]
+  induction signatures generalizing groups remaining with
+  | zero => rfl
+  | succ signatures ih =>
+      simp only [Function.iterate_succ_apply']
+      have hsign : (targetShapeSigning uniform reuse)^[signatures]
+          (fun G R => scalar * (targetShapeQuery arrival)^[queries] moments G R) =
+          fun G R => scalar * (targetShapeSigning uniform reuse)^[signatures] ((targetShapeQuery arrival)^[queries] moments) G R := by
+        funext G R
+        exact ih G R
+      rw [hsign]
+      exact targetShapeSigning_mul uniform reuse scalar _ groups remaining
+
+theorem targetShapeEnvelope_expected {α : Type} (uniform reuse arrival : ENNReal) (queries signatures : Nat)
+    (weight : α → ENNReal) (moments : α → TargetShapeVector) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) :
+    (∑' result, weight result * targetShapeEnvelope uniform reuse arrival queries signatures (moments result) groups remaining) =
+      targetShapeEnvelope uniform reuse arrival queries signatures (fun G R => ∑' result, weight result * moments result G R) groups remaining := by
+  rw [targetShapeEnvelope_tsum]
+  apply tsum_congr
+  intro result
+  exact (targetShapeEnvelope_mul uniform reuse arrival (weight result) queries signatures (moments result) groups remaining).symm
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/TargetShapeOperators.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/TargetShapeOperators.lean
new file mode 100644
index 000000000..f00ebb4af
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/TargetShapeOperators.lean
@@ -0,0 +1,106 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.TargetMomentShapes
+namespace SphincsSecurity.Concrete
+
+open ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+abbrev TargetShapeVector := Finset (Finset FtsTree) → Finset FtsTree → ENNReal
+
+noncomputable def targetCacheAll (f : TargetShapeVector) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) : ENNReal :=
+  ∑ kept ∈ groups.powerset, f kept remaining
+
+noncomputable def targetCacheLower (f : TargetShapeVector) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) : ENNReal :=
+  ∑ kept ∈ groups.powerset.erase groups, f kept remaining
+
+noncomputable def targetTreeLower (f : TargetShapeVector) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) : ENNReal :=
+  ∑ selected ∈ remaining.powerset.erase ∅, f groups (remaining \ selected)
+
+noncomputable def targetReuseStep (f : TargetShapeVector) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) : ENNReal :=
+  ∑ selected ∈ remaining.powerset.erase ∅, f (insert selected groups) (remaining \ selected)
+
+theorem targetCacheAll_eq (f : TargetShapeVector) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) :
+    targetCacheAll f groups remaining = f groups remaining + targetCacheLower f groups remaining := by
+  exact (Finset.add_sum_erase _ _ (Finset.mem_powerset.mpr (Finset.Subset.refl groups))).symm
+
+theorem targetCacheLower_add (f g : TargetShapeVector) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) :
+    targetCacheLower (fun G R => f G R + g G R) groups remaining = targetCacheLower f groups remaining + targetCacheLower g groups remaining := by
+  simp only [targetCacheLower, Finset.sum_add_distrib]
+
+theorem targetTreeLower_add (f g : TargetShapeVector) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) :
+    targetTreeLower (fun G R => f G R + g G R) groups remaining = targetTreeLower f groups remaining + targetTreeLower g groups remaining := by
+  simp only [targetTreeLower, Finset.sum_add_distrib]
+
+theorem targetReuseStep_add (f g : TargetShapeVector) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) :
+    targetReuseStep (fun G R => f G R + g G R) groups remaining = targetReuseStep f groups remaining + targetReuseStep g groups remaining := by
+  simp only [targetReuseStep, Finset.sum_add_distrib]
+
+theorem targetCacheLower_mul (c : ENNReal) (f : TargetShapeVector) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) :
+    targetCacheLower (fun G R => c * f G R) groups remaining = c * targetCacheLower f groups remaining := by
+  simp only [targetCacheLower, Finset.mul_sum]
+
+theorem targetTreeLower_mul (c : ENNReal) (f : TargetShapeVector) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) :
+    targetTreeLower (fun G R => c * f G R) groups remaining = c * targetTreeLower f groups remaining := by
+  simp only [targetTreeLower, Finset.mul_sum]
+
+theorem targetReuseStep_mul (c : ENNReal) (f : TargetShapeVector) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) :
+    targetReuseStep (fun G R => c * f G R) groups remaining = c * targetReuseStep f groups remaining := by
+  simp only [targetReuseStep, Finset.mul_sum]
+
+theorem targetCacheLower_tree_commute (f : TargetShapeVector) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) :
+    targetCacheLower (targetTreeLower f) groups remaining = targetTreeLower (targetCacheLower f) groups remaining := by
+  unfold targetCacheLower targetTreeLower
+  exact Finset.sum_comm
+
+private theorem sum_erase_as_indicator {α : Type} [DecidableEq α] (s : Finset α) (a : α) (f : α → ENNReal) :
+    (∑ x ∈ s.erase a, f x) = ∑ x ∈ s, if x = a then 0 else f x := by
+  rw [← Finset.filter_ne', Finset.sum_filter]
+  apply Finset.sum_congr rfl
+  intro x _
+  by_cases h : x = a <;> simp only [h, ne_eq, not_true_eq_false, not_false_eq_true, if_true, if_false]
+
+theorem targetCacheLower_insert (f : TargetShapeVector) (groups : Finset (Finset FtsTree)) (remaining selected : Finset FtsTree)
+    (hnot : selected ∉ groups) :
+    targetCacheLower f (insert selected groups) remaining = targetCacheAll f groups remaining +
+      targetCacheLower (fun G R => f (insert selected G) R) groups remaining := by
+  unfold targetCacheLower targetCacheAll
+  rw [sum_erase_as_indicator, Finset.sum_powerset_insert hnot]
+  rw [sum_erase_as_indicator]
+  congr 1
+  · apply Finset.sum_congr rfl
+    intro kept hkept
+    have hne : kept ≠ insert selected groups := by
+      intro heq
+      exact hnot ((Finset.mem_powerset.mp hkept) (heq ▸ Finset.mem_insert_self selected groups))
+    exact if_neg hne
+  · apply Finset.sum_congr rfl
+    intro kept hkept
+    have hkeptNot : selected ∉ kept := fun hmem => hnot ((Finset.mem_powerset.mp hkept) hmem)
+    have heq : insert selected kept = insert selected groups ↔ kept = groups := by
+      constructor
+      · intro heq
+        have h := congrArg (fun s : Finset (Finset FtsTree) => s.erase selected) heq
+        simpa only [Finset.erase_insert hkeptNot, Finset.erase_insert hnot] using h
+      · rintro rfl; rfl
+    simp only [heq]
+
+theorem targetReuse_cache_commute (f : TargetShapeVector) (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree)
+    (hvalid : TargetShapeValid groups remaining) :
+    targetReuseStep (targetCacheLower f) groups remaining =
+      targetCacheLower (targetReuseStep f) groups remaining + targetTreeLower f groups remaining +
+        targetCacheLower (targetTreeLower f) groups remaining := by
+  unfold targetReuseStep
+  have hinsert (selected : Finset FtsTree) (hselected : selected ∈ remaining.powerset.erase ∅) :
+      targetCacheLower f (insert selected groups) (remaining \ selected) = targetCacheAll f groups (remaining \ selected) +
+        targetCacheLower (fun G R => f (insert selected G) R) groups (remaining \ selected) :=
+    targetCacheLower_insert f groups _ selected (hvalid.new_group
+      (Finset.nonempty_iff_ne_empty.mpr (Finset.mem_erase.mp hselected).1)
+      (Finset.mem_powerset.mp (Finset.mem_erase.mp hselected).2))
+  rw [Finset.sum_congr rfl hinsert]
+  simp only [targetCacheAll_eq, Finset.sum_add_distrib, targetCacheLower, targetTreeLower]
+  rw [Finset.sum_comm (s := remaining.powerset.erase ∅) (t := groups.powerset.erase groups)]
+  rw [Finset.sum_comm (s := remaining.powerset.erase ∅) (t := groups.powerset.erase groups)]
+  ring
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/TargetShapeReindex.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/TargetShapeReindex.lean
new file mode 100644
index 000000000..2c567eabd
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/TargetShapeReindex.lean
@@ -0,0 +1,66 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Statement
+
+namespace SphincsSecurity.Concrete
+
+open ENNReal
+attribute [local instance] Classical.propDecidable
+
+noncomputable def targetGroupAt (groups : Finset (Finset FtsTree)) (slot : Fin groups.card) : Finset FtsTree :=
+  (groups.equivFin.symm slot).val
+
+theorem targetGroupAt_mem (groups : Finset (Finset FtsTree)) (slot : Fin groups.card) : targetGroupAt groups slot ∈ groups :=
+  (groups.equivFin.symm slot).property
+
+theorem targetGroupAt_injective (groups : Finset (Finset FtsTree)) : Function.Injective (targetGroupAt groups) :=
+  fun _ _ h => groups.equivFin.symm.injective (Subtype.ext h)
+
+theorem targetGroupAt_image (groups : Finset (Finset FtsTree)) : Finset.univ.image (targetGroupAt groups) = groups := by
+  ext group
+  constructor
+  · intro h
+    obtain ⟨slot, _, rfl⟩ := Finset.mem_image.mp h
+    exact targetGroupAt_mem groups slot
+  · intro h
+    exact Finset.mem_image.mpr ⟨groups.equivFin ⟨group, h⟩, Finset.mem_univ _, by simp [targetGroupAt]⟩
+
+theorem prod_targetGroupAt (groups : Finset (Finset FtsTree)) (f : Finset FtsTree → ENNReal) :
+    (∏ slot : Fin groups.card, f (targetGroupAt groups slot)) = ∏ group ∈ groups, f group := by
+  calc
+    _ = ∏ group ∈ Finset.univ.image (targetGroupAt groups), f group :=
+      (Finset.prod_image (targetGroupAt_injective groups).injOn).symm
+    _ = _ := by rw [targetGroupAt_image]
+
+theorem sum_targetGroupAt_proper (groups : Finset (Finset FtsTree)) (f : Finset (Finset FtsTree) → ENNReal) :
+    (∑ kept ∈ (Finset.univ : Finset (Fin groups.card)).powerset.erase Finset.univ,
+      f (kept.image (targetGroupAt groups))) = ∑ kept ∈ groups.powerset.erase groups, f kept := by
+  have hi := Finset.image_injective (targetGroupAt_injective groups)
+  rw [← Finset.sum_image hi.injOn, Finset.image_erase hi, ← Finset.powerset_image, targetGroupAt_image]
+
+theorem sum_nonempty_sdiff_eq_proper {α : Type} [DecidableEq α] (s : Finset α) (f : Finset α → ENNReal) :
+    (∑ removed ∈ s.powerset.erase ∅, f (s \ removed)) = ∑ kept ∈ s.powerset.erase s, f kept := by
+  apply Finset.sum_bij' (fun removed _ => s \ removed) (fun kept _ => s \ kept)
+  · intro removed hremoved
+    obtain ⟨hne, hsub⟩ := Finset.mem_erase.mp hremoved
+    exact Finset.mem_erase.mpr ⟨(Finset.sdiff_ssubset (Finset.mem_powerset.mp hsub)
+      (Finset.nonempty_iff_ne_empty.mpr hne)).ne, Finset.mem_powerset.mpr Finset.sdiff_subset⟩
+  · intro kept hkept
+    obtain ⟨hne, hsub⟩ := Finset.mem_erase.mp hkept
+    refine Finset.mem_erase.mpr ⟨?_, Finset.mem_powerset.mpr Finset.sdiff_subset⟩
+    intro hempty
+    exact hne (Finset.Subset.antisymm (Finset.mem_powerset.mp hsub) (Finset.sdiff_eq_empty_iff_subset.mp hempty))
+  · intro removed hremoved
+    exact Finset.sdiff_sdiff_eq_self (Finset.mem_powerset.mp (Finset.mem_erase.mp hremoved).2)
+  · intro kept hkept
+    exact Finset.sdiff_sdiff_eq_self (Finset.mem_powerset.mp (Finset.mem_erase.mp hkept).2)
+  · intro _ _; rfl
+
+theorem sum_targetGroupAt_removed_products (groups : Finset (Finset FtsTree)) (f : Finset FtsTree → ENNReal) :
+    (∑ removed ∈ (Finset.univ : Finset (Fin groups.card)).powerset.erase ∅,
+      ∏ slot ∈ (Finset.univ : Finset (Fin groups.card)) \ removed, f (targetGroupAt groups slot)) =
+      ∑ kept ∈ groups.powerset.erase groups, ∏ group ∈ kept, f group := by
+  rw [sum_nonempty_sdiff_eq_proper _ (fun kept => ∏ slot ∈ kept, f (targetGroupAt groups slot))]
+  simp only [← Finset.prod_image (targetGroupAt_injective groups).injOn]
+  exact sum_targetGroupAt_proper groups (fun kept => ∏ group ∈ kept, f group)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/TargetSigningMatchFactors.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/TargetSigningMatchFactors.lean
new file mode 100644
index 000000000..276e5b871
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/TargetSigningMatchFactors.lean
@@ -0,0 +1,86 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CachedSigningViews
+import SphincsSecurity.Proof.Fts.NormalizedTargetMatches
+
+/-! ## TargetAssignmentReuse -/
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem targetTreeMatchCount_log (log : List α) (view : α → Option FewTimeView) (target : FewTimeView) (tree : FtsTree) :
+    targetTreeMatchCount (fun slot => view (log.get slot)) target tree =
+      (log.map (fun entry => if ∃ source, view entry = some source ∧ source.1 = target.1 ∧ source.2 tree = target.2 tree then 1 else 0)).sum := by
+  rw [targetTreeMatchCount, ← List.sum_ofFn]
+  exact congrArg List.sum (List.ofFn_getElem_eq_map log
+    (fun entry => if ∃ source, view entry = some source ∧ source.1 = target.1 ∧ source.2 tree = target.2 tree then 1 else 0))
+
+theorem targetTreeMatchCount_log_append (log suffix : List α) (view : α → Option FewTimeView) (target : FewTimeView) (tree : FtsTree) :
+    targetTreeMatchCount (fun slot => view ((log ++ suffix).get slot)) target tree =
+      targetTreeMatchCount (fun slot => view (log.get slot)) target tree +
+        targetTreeMatchCount (fun slot => view (suffix.get slot)) target tree := by
+  simp only [targetTreeMatchCount_log, List.map_append, List.sum_append]
+
+end SphincsSecurity.Concrete
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (messageAnswers)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def normalizedTargetLogMatch (key : SecretKey) (cache : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView) (tree : FtsTree) : ENNReal :=
+  (Fintype.card FtsLeaf : ENNReal) *
+    (targetTreeMatchCount (eligibleSigningViews (messageAnswers key.parameter cache) key.root payload log) target tree : ENNReal)
+
+noncomputable def normalizedTargetLogProduct (key : SecretKey) (cache : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (payload : HashInput) (target : FewTimeView) (required : Finset FtsTree) : ENNReal :=
+  ∏ tree ∈ required, normalizedTargetLogMatch key cache log payload target tree
+
+theorem targetTreeMatchCount_log_append_singleton (log : List α) (entry : α) (view : α → Option FewTimeView)
+    (target : FewTimeView) (tree : FtsTree) :
+    targetTreeMatchCount (fun slot => view ((log ++ [entry]).get slot)) target tree =
+      targetTreeMatchCount (fun slot => view (log.get slot)) target tree +
+        if ∃ source, view entry = some source ∧ source.1 = target.1 ∧ source.2 tree = target.2 tree then 1 else 0 := by
+  simp only [targetTreeMatchCount_log_append, targetTreeMatchCount_log, List.map_cons, List.map_nil,
+    List.sum_cons, List.sum_nil, add_zero]
+
+theorem normalizedSourceSubsetMatch_singleton (target source : FewTimeView) (tree : FtsTree) :
+    normalizedSourceSubsetMatch target source {tree} = (Fintype.card FtsLeaf : ENNReal) * (sourceTreeMatch target source tree : ENNReal) := by
+  simp only [normalizedSourceSubsetMatch, Finset.card_singleton, pow_one, sourceSubsetMatch, Finset.prod_singleton]
+
+theorem eligibleSigningViews_cache_stable (key : SecretKey) (before after : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (payload : HashInput) (hcache : before ≤ after)
+    (hsigned : SigningDigestsCached key.parameter before key.root log) :
+    eligibleSigningViews (messageAnswers key.parameter after) key.root payload log =
+      eligibleSigningViews (messageAnswers key.parameter before) key.root payload log := by
+  funext slot
+  exact eligibleSigningView?_cache_stable key.parameter key.root before after hcache payload (log.get slot)
+    (hsigned _ (List.get_mem _ _))
+
+theorem normalizedTargetLogMatch_le_of_eligibleView (key : SecretKey) (before after : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (entry : SigningEntry) (payload : HashInput) (target source : FewTimeView) (tree : FtsTree)
+    (hcache : before ≤ after) (hsigned : SigningDigestsCached key.parameter before key.root log)
+    (hentry : eligibleSigningView? (messageAnswers key.parameter after) key.root payload entry = none ∨
+      eligibleSigningView? (messageAnswers key.parameter after) key.root payload entry = some source) :
+    normalizedTargetLogMatch key after (log ++ [entry]) payload target tree ≤
+      normalizedTargetLogMatch key before log payload target tree + normalizedSourceSubsetMatch target source {tree} := by
+  have hstable := eligibleSigningViews_cache_stable key before after log payload hcache hsigned
+  have hstep := targetTreeMatchCount_log_append_singleton log entry
+    (eligibleSigningView? (messageAnswers key.parameter after) key.root payload) target tree
+  change targetTreeMatchCount (eligibleSigningViews (messageAnswers key.parameter after) key.root payload (log ++ [entry])) target tree =
+    targetTreeMatchCount (eligibleSigningViews (messageAnswers key.parameter after) key.root payload log) target tree + _ at hstep
+  rw [hstable] at hstep
+  rw [normalizedTargetLogMatch, hstep, Nat.cast_add, mul_add, normalizedSourceSubsetMatch_singleton]
+  apply add_le_add le_rfl
+  apply mul_le_mul' le_rfl
+  apply Nat.cast_le.mpr
+  rcases hentry with hnone | hsome
+  · simp only [hnone, reduceCtorEq, false_and, exists_false, if_false, Nat.zero_le]
+  · simp only [hsome, Option.some.injEq, exists_eq_left', sourceTreeMatch, le_refl]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/TargetSourceMultiplicity.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/TargetSourceMultiplicity.lean
new file mode 100644
index 000000000..5748c6e0e
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/TargetSourceMultiplicity.lean
@@ -0,0 +1,73 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FewTimeConditionalCoverage
+import SphincsSecurity.Proof.Fts.NormalizedTargetCacheQuery
+import SphincsSecurity.Proof.Fts.TargetSigningMatchFactors
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def excludedCacheSourceCount (parameter : PublicParameter) (cache : QueryCache HashSpec)
+    (targetInput : HashInput) (source : FewTimeView) : ENNReal :=
+  cacheMessageWeight parameter (fun input view => if input = targetInput then 0 else if view = source then 1 else 0) cache
+
+theorem excludedCacheSourceCount_weight (parameter : PublicParameter) (cache : QueryCache HashSpec)
+    (targetInput : HashInput) (weight : FewTimeView → ENNReal) :
+    (∑ source : FewTimeView, excludedCacheSourceCount parameter cache targetInput source * weight source) =
+      cacheMessageWeight parameter (fun input view => if input = targetInput then 0 else weight view) cache := by
+  simp only [excludedCacheSourceCount, ← cacheMessageWeight_mul_right]
+  rw [← cacheMessageWeight_sum]
+  apply congrArg (fun f : HashInput → FewTimeView → ENNReal => cacheMessageWeight parameter f cache)
+  funext input view
+  by_cases heq : input = targetInput
+  · simp only [heq, if_true, zero_mul, Finset.sum_const_zero]
+  · simp only [heq, if_false, ite_mul, one_mul, zero_mul, Finset.sum_ite_eq, Finset.mem_univ, if_true]
+
+theorem normalizedCachedTargetSubsetMatch_eq_sourceCount (parameter : PublicParameter) (cache : QueryCache HashSpec)
+    (targetInput : HashInput) (target : FewTimeView) (required : Finset FtsTree) :
+    normalizedCachedTargetSubsetMatch parameter cache targetInput target required =
+      ∑ source : FewTimeView, excludedCacheSourceCount parameter cache targetInput source * normalizedSourceSubsetMatch target source required := by
+  rw [excludedCacheSourceCount_weight, normalizedCachedTargetSubsetMatch_eq_weight]
+
+noncomputable def optionalSourceCount (views : Fin n → Option FewTimeView) (source : FewTimeView) : ENNReal :=
+  ∑ slot : Fin n, if views slot = some source then 1 else 0
+
+theorem optionalSourceCount_weight (views : Fin n → Option FewTimeView) (weight : FewTimeView → ENNReal) :
+    (∑ source : FewTimeView, optionalSourceCount views source * weight source) =
+      ∑ slot : Fin n, match views slot with | none => 0 | some source => weight source := by
+  simp only [optionalSourceCount, Finset.sum_mul]
+  rw [Finset.sum_comm]
+  apply Finset.sum_congr rfl
+  intro slot _
+  cases hview : views slot with
+  | none => simp only [reduceCtorEq, if_false, zero_mul, Finset.sum_const_zero]
+  | some source => simp only [Option.some.injEq, ite_mul, one_mul, zero_mul, Finset.sum_ite_eq, Finset.mem_univ, if_true]
+
+theorem normalizedTargetTreeMatchCount_eq_sourceCount (views : Fin n → Option FewTimeView) (target : FewTimeView) (tree : FtsTree) :
+    (Fintype.card FtsLeaf : ENNReal) * (targetTreeMatchCount views target tree : ENNReal) =
+      ∑ source : FewTimeView, optionalSourceCount views source * normalizedSourceSubsetMatch target source {tree} := by
+  rw [optionalSourceCount_weight]
+  simp only [targetTreeMatchCount, Nat.cast_sum, Finset.mul_sum]
+  apply Finset.sum_congr rfl
+  intro slot _
+  cases hview : views slot with
+  | none => simp only [reduceCtorEq, false_and, exists_false, if_false, Nat.cast_zero, mul_zero]
+  | some source => simp only [Option.some.injEq, exists_eq_left', normalizedSourceSubsetMatch_singleton, sourceTreeMatch]
+
+theorem optionalSourceCount_index (views : Fin n → Option FewTimeView) (index : Index) :
+    (∑ source : FewTimeView, if source.1 = index then optionalSourceCount views source else 0) =
+      ((signingSlotsAtIndex views index).card : ENNReal) := by
+  have heq (source : FewTimeView) : (if source.1 = index then optionalSourceCount views source else 0) =
+      optionalSourceCount views source * (if source.1 = index then 1 else 0) := by
+    split_ifs <;> simp only [mul_one, mul_zero]
+  simp only [heq]
+  rw [optionalSourceCount_weight]
+  simp only [signingSlotsAtIndex, Finset.card_eq_sum_ones, Finset.sum_filter, Nat.cast_sum]
+  apply Finset.sum_congr rfl
+  intro slot _
+  cases hview : views slot with
+  | none => simp only [reduceCtorEq, false_and, exists_false, if_false, Nat.cast_zero]
+  | some source => simp only [Option.some.injEq, exists_eq_left', Nat.cast_ite, Nat.cast_one, Nat.cast_zero]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/TerminalCache.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/TerminalCache.lean
new file mode 100644
index 000000000..bcebaf883
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/TerminalCache.lean
@@ -0,0 +1,28 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Scheme.Cached
+/-!
+# 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
+
+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
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/TerminalCertificateCharge.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/TerminalCertificateCharge.lean
new file mode 100644
index 000000000..5891e4063
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/TerminalCertificateCharge.lean
@@ -0,0 +1,227 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CertificateProposalInvariant
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+private noncomputable def expectedStateCharge {ι σ α : Type} {spec : OracleSpec ι}
+    (impl : QueryImpl spec (StateT σ PMF)) (charge : spec.Domain → σ → ENNReal)
+    (computation : OracleComp spec α) : σ → ENNReal :=
+  OracleComp.construct (fun _ _ => 0)
+    (fun input _ next state => charge input state +
+      ∑' result, Pr[= result | (impl input).run state] * next result.1 result.2) computation
+
+private theorem expectedStateCharge_query_bind {ι σ α : Type} {spec : OracleSpec ι}
+    (impl : QueryImpl spec (StateT σ PMF)) (charge : spec.Domain → σ → ENNReal)
+    (input : spec.Domain) (next : spec.Range input → OracleComp spec α) (state : σ) :
+    expectedStateCharge impl charge (OracleSpec.query input >>= next) state =
+      charge input state + ∑' result, Pr[= result | (impl input).run state] *
+        expectedStateCharge impl charge (next result.1) result.2 := rfl
+
+private theorem expectedStateCharge_mono {ι σ α : Type} {spec : OracleSpec ι}
+    (impl : QueryImpl spec (StateT σ PMF)) (first second : spec.Domain → σ → ENNReal)
+    (invariant : σ → Prop)
+    (hpreserve : ∀ input state, invariant state → ∀ result ∈ ((impl input).run state).support, invariant result.2)
+    (hle : ∀ input state, invariant state → first input state ≤ second input state)
+    (computation : OracleComp spec α) (state : σ) (hinv : invariant state) :
+    expectedStateCharge impl first computation state ≤ expectedStateCharge impl second computation state := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => exact le_rfl
+  | query_bind input next ih =>
+      rw [expectedStateCharge_query_bind, expectedStateCharge_query_bind]
+      apply add_le_add (hle input state hinv)
+      apply ENNReal.tsum_le_tsum
+      intro result
+      by_cases hr : result ∈ ((impl input).run state).support
+      · exact mul_le_mul' le_rfl (ih result.1 result.2 (hpreserve input state hinv result hr))
+      · have hp : Pr[= result | (impl input).run state] = 0 := by
+          rw [PMF.probOutput_eq_apply, PMF.apply_eq_zero_iff]
+          exact hr
+        rw [hp, zero_mul, zero_mul]
+
+private theorem expected_state_accumulator {ι σ α : Type} {spec : OracleSpec ι}
+    (impl : QueryImpl spec (StateT σ PMF)) (counter : σ → ENNReal) (charge : spec.Domain → σ → ENNReal)
+    (hstep : ∀ input state, (∑' result, Pr[= result | (impl input).run state] * counter result.2) =
+      counter state + charge input state)
+    (computation : OracleComp spec α) (state : σ) :
+    (∑' result, Pr[= result | (simulateQ impl computation).run state] * counter result.2) =
+      counter state + expectedStateCharge impl charge computation state := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [simulateQ_pure, StateT.run_pure, tsum_probOutput_pure_mul,
+      expectedStateCharge, OracleComp.construct_pure, add_zero]
+  | query_bind input next ih =>
+      rw [simulateQ_bind, simulateQ_spec_query, StateT.run_bind, tsum_probOutput_bind_mul,
+        expectedStateCharge_query_bind]
+      simp_rw [ih, mul_add, ENNReal.tsum_add]
+      rw [hstep, add_assoc]
+
+private theorem expected_pmf_congr_of_support {α : Type} (law : PMF α) (first second : α → ENNReal)
+    (heq : ∀ result ∈ law.support, first result = second result) :
+    (∑' result, Pr[= result | law] * first result) = ∑' result, Pr[= result | law] * second result := by
+  apply tsum_congr
+  intro result
+  by_cases hr : result ∈ law.support
+  · rw [heq result hr]
+  · have hp : Pr[= result | law] = 0 := by
+      rw [PMF.probOutput_eq_apply, PMF.apply_eq_zero_iff]
+      exact hr
+    rw [hp, zero_mul, zero_mul]
+
+theorem certificateProposalImpl_counter_support (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : List Index × CertificateMonitorState)
+    (counter : CertificateMonitorState → ENNReal) (value : ENNReal)
+    (hadvance : ∀ length record, counter
+      (originalProposalAdvance (certificateMonitorUpdate key budget required stopAfter) input state.2 length record) = value)
+    (result : (OracleWorld + SigningSpec).Range input × (List Index × CertificateMonitorState))
+    (hr : result ∈ ((certificateProposalImpl key budget required stopAfter input).run state).support) :
+    counter result.2.2 = value := by
+  simp only [certificateProposalImpl, originalProposalImpl, proposalRecordImpl, StateT.run_mk] at hr
+  split at hr <;> rw [PMF.mem_support_map_iff] at hr
+  · obtain ⟨source, _, rfl⟩ := hr
+    exact hadvance _ _
+  · obtain ⟨record, _, rfl⟩ := hr
+    exact hadvance _ _
+
+theorem expected_certificateProposalImpl_creationCost (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : List Index × CertificateMonitorState) :
+    (∑' result, Pr[= result | (certificateProposalImpl key budget required stopAfter input).run state] *
+      result.2.2.2.creationCost) = state.2.2.creationCost + certificateMonitorCharge key budget required input state.2 := by
+  rw [expected_pmf_congr_of_support _ _ (fun _ => state.2.2.creationCost +
+    certificateMonitorCharge key budget required input state.2) (fun result hr =>
+      certificateProposalImpl_counter_support key budget required stopAfter input state
+        (fun state => state.2.creationCost) _
+        (certificateMonitorUpdate_creationCost key budget required stopAfter input state.2) result hr)]
+  simp only [ENNReal.tsum_mul_right, PMF.probOutput_eq_apply, PMF.tsum_coe, one_mul]
+
+theorem expected_certificateProposalImpl_mass_terminalPotential (key : SecretKey) (budget total : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule) (payoff : List Index → ENNReal)
+    (input : (OracleWorld + SigningSpec).Domain) (state : List Index × CertificateMonitorState) :
+    (∑' result, Pr[= result | (certificateProposalImpl key budget required stopAfter input).run state] *
+      (result.2.2.2.creationMass * terminalProposalPotential (PMF.uniformOfFintype Index) total payoff result.2.1)) =
+        state.2.2.creationMass * terminalProposalPotential (PMF.uniformOfFintype Index) total payoff state.1 +
+          certificateMonitorMass key budget input state.2 *
+            terminalProposalPotential (PMF.uniformOfFintype Index) total payoff state.1 := by
+  let mass := state.2.2.creationMass + certificateMonitorMass key budget input state.2
+  calc
+    _ = ∑' result, Pr[= result | (certificateProposalImpl key budget required stopAfter input).run state] *
+        (mass * terminalProposalPotential (PMF.uniformOfFintype Index) total payoff result.2.1) := by
+      apply expected_pmf_congr_of_support
+      intro result hr
+      rw [certificateProposalImpl_counter_support key budget required stopAfter input state
+        (fun state => state.2.creationMass) mass
+        (certificateMonitorUpdate_creationMass key budget required stopAfter input state.2) result hr]
+    _ = mass * ∑' result, Pr[= result | (certificateProposalImpl key budget required stopAfter input).run state] *
+        terminalProposalPotential (PMF.uniformOfFintype Index) total payoff result.2.1 := by
+      simp_rw [mul_left_comm _ mass]
+      exact ENNReal.tsum_mul_left
+    _ = _ := by
+      rw [expected_certificateProposalImpl_terminalPotential]
+      exact add_mul _ _ _
+
+theorem expected_certificateProposal_creationCost_le_mass_terminalPotential {α : Type}
+    (key : SecretKey) (budget total : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) (state : List Index × CertificateMonitorState)
+    (hbudget : budget ≤ 2 ^ 127) (hinv : CertificateProposalInvariant key total state) :
+    (∑' result, Pr[= result | (simulateQ (certificateProposalImpl key budget required
+      (fun input state length record => proposalPrefixStop input state length record || stopAfter input state length record))
+      computation).run state] * result.2.2.2.creationCost) ≤
+      state.2.2.creationCost +
+        ∑' result, Pr[= result | (simulateQ (certificateProposalImpl key budget required
+          (fun input state length record => proposalPrefixStop input state length record || stopAfter input state length record))
+          computation).run state] * (result.2.2.2.creationMass *
+            terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice required) result.2.1) := by
+  let guarded : CertificateStopRule := fun input state length record =>
+    proposalPrefixStop input state length record || stopAfter input state length record
+  let impl := certificateProposalImpl key budget required guarded
+  let first := fun input (state : List Index × CertificateMonitorState) =>
+    certificateMonitorCharge key budget required input state.2
+  let second := fun input (state : List Index × CertificateMonitorState) =>
+    certificateMonitorMass key budget input state.2 *
+      terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice required) state.1
+  have hcost := expected_state_accumulator impl (fun state => state.2.2.creationCost) first
+    (expected_certificateProposalImpl_creationCost key budget required guarded) computation state
+  have hmass := expected_state_accumulator impl (fun state => state.2.2.creationMass *
+      terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice required) state.1) second
+    (expected_certificateProposalImpl_mass_terminalPotential key budget total required guarded (terminalCertificatePrice required))
+    computation state
+  have hcharge := expectedStateCharge_mono impl first second (CertificateProposalInvariant key total)
+    (certificateProposalImpl_invariant key budget total required stopAfter)
+    (fun input state hinv => certificateMonitorCharge_le_terminalPrice_of_invariant key budget total required input state hbudget hinv)
+    computation state hinv
+  calc
+    _ = state.2.2.creationCost + expectedStateCharge impl first computation state := hcost
+    _ ≤ state.2.2.creationCost + expectedStateCharge impl second computation state := add_le_add le_rfl hcharge
+    _ ≤ _ := by rw [hmass]; exact add_le_add le_rfl le_add_self
+
+theorem expected_certificateTerminalGame_project (adversary : Adversary) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : SecretKey → CertificateStopRule) (stopped : Bool) (total : Nat)
+    (weight : CertificateGameResult → ENNReal) :
+    (∑' result, Pr[= result | certificateTerminalGame adversary budget required stopAfter stopped total] * weight result.1) =
+      ∑' result, Pr[= result | certificateGame adversary budget required stopAfter stopped] * weight result := by
+  have h := congrArg (fun law : PMF CertificateGameResult => ∑' result, Pr[= result | law] * weight result)
+    (certificateTerminalGame_game adversary budget required stopAfter stopped total)
+  rw [← PMF.monad_map_eq_map, tsum_probOutput_map_mul] at h
+  exact h
+
+theorem expected_certificateTerminalGame_weight_payoff (adversary : Adversary) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : SecretKey → CertificateStopRule) (stopped : Bool) (total : Nat)
+    (weight : CertificateGameResult → ENNReal) (payoff : List Index → ENNReal) :
+    (∑' result, Pr[= result | certificateTerminalGame adversary budget required stopAfter stopped total] *
+      (weight result.1 * payoff result.2)) =
+        ∑' result, Pr[= result | certificateGame adversary budget required stopAfter stopped] *
+          (weight result * terminalProposalPotential (PMF.uniformOfFintype Index) total payoff result.2.1) := by
+  rw [certificateTerminalGame, ← PMF.monad_bind_eq_bind, tsum_probOutput_bind_mul]
+  simp_rw [← PMF.monad_map_eq_map, tsum_probOutput_map_mul]
+  apply tsum_congr
+  intro result
+  congr 1
+  calc
+    _ = ∑' word, weight result *
+        (Pr[= word | completeProposalWord (PMF.uniformOfFintype Index) total result.2.1] * payoff word) := by
+      apply tsum_congr
+      intro word
+      ring
+    _ = _ := ENNReal.tsum_mul_left
+
+theorem expected_certificateGame_creationCost_le_terminalPotential (adversary : Adversary)
+    (budget total : Nat) (required : Finset FtsTree) (stopAfter : SecretKey → CertificateStopRule)
+    (hbudget : budget ≤ 2 ^ 127) :
+    (∑' result, Pr[= result | certificateGame adversary budget required
+      (fun key input state length record => proposalPrefixStop input state length record || stopAfter key input state length record)
+      (decide (total < 25313293))] * result.2.2.2.creationCost) ≤
+        ∑' result, Pr[= result | certificateGame adversary budget required
+          (fun key input state length record => proposalPrefixStop input state length record || stopAfter key input state length record)
+          (decide (total < 25313293))] * (result.2.2.2.creationMass *
+            terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice required) result.2.1) := by
+  rw [certificateGame, tsum_probOutput_bind_mul, tsum_probOutput_bind_mul]
+  apply ENNReal.tsum_le_tsum
+  intro generated
+  apply mul_le_mul' le_rfl
+  have hinv := certificateProposalInvariant_initial generated.1.1.2 total generated.1.2.hashCalls generated.2
+    (decide (total < 25313293)) (fun h => Nat.le_of_not_lt (of_decide_eq_false h))
+  simpa only [initialCertificateMonitor, zero_add] using
+    expected_certificateProposal_creationCost_le_mass_terminalPotential generated.1.1.2 budget total required
+      (stopAfter generated.1.1.2) (FtsProbeSimulation.retainedGameRestComputation adversary generated.1.1.1)
+      ([], generated.2, initialCertificateMonitor generated.1.2.hashCalls (decide (total < 25313293))) hbudget hinv
+
+theorem expected_certificateTerminalGame_count_le_mass_price (adversary : Adversary)
+    (budget total : Nat) (required : Finset FtsTree) (stopAfter : SecretKey → CertificateStopRule)
+    (hbudget : budget ≤ 2 ^ 127) :
+    (∑' result, Pr[= result | certificateTerminalGame adversary budget required
+      (fun key input state length record => proposalPrefixStop input state length record || stopAfter key input state length record)
+      (decide (total < 25313293)) total] * certificateBankCount result.1.2.2.2.bank) ≤
+        ∑' result, Pr[= result | certificateTerminalGame adversary budget required
+          (fun key input state length record => proposalPrefixStop input state length record || stopAfter key input state length record)
+          (decide (total < 25313293)) total] * (result.1.2.2.2.creationMass * terminalCertificatePrice required result.2) := by
+  rw [expected_certificateTerminalGame_project adversary budget required _ _ total
+      (fun result => certificateBankCount result.2.2.2.bank),
+    expected_certificateTerminalGame_weight_payoff adversary budget required _ _ total
+      (fun result => result.2.2.2.creationMass) (terminalCertificatePrice required)]
+  exact (expected_certificateGame_count_le_creationCost adversary budget required _ _).trans
+    (expected_certificateGame_creationCost_le_terminalPotential adversary budget total required stopAfter hbudget)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/TerminalProposalEnvelope.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/TerminalProposalEnvelope.lean
new file mode 100644
index 000000000..8c9c4ce23
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/TerminalProposalEnvelope.lean
@@ -0,0 +1,108 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CertificateMonitor
+import SphincsSecurity.Proof.Fts.OriginalTerminalProposal
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+
+noncomputable def terminalCertificatePrice (required : Finset FtsTree) (word : List Index) : ENNReal :=
+  (((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ * (Fintype.card Index : ENNReal)⁻¹) *
+    (∑ index : Index, (word.count index : ENNReal) ^ required.card) * targetCertificateScale required
+
+theorem terminalProposalPotential_eq_uniform_suffix (total : Nat) (consumed : List Index)
+    (hused : consumed.length ≤ total) (payoff : List Index → ENNReal) :
+    terminalProposalPotential (PMF.uniformOfFintype Index) total payoff consumed =
+      ∑' suffix, Pr[= suffix | sampleUniformProposalWord Index (total - consumed.length)] *
+        payoff (consumed ++ suffix) := by
+  rw [terminalProposalPotential, completeProposalWord_eq_padding, ← PMF.monad_map_eq_map,
+    tsum_probOutput_map_mul, List.take_of_length_le hused]
+  apply tsum_congr
+  intro suffix
+  simp only [probOutput_def, evalDist_sampleUniformProposalWord, PMF.evalDist_eq]
+
+theorem terminalProposalPotential_scale {α : Type} (base : PMF α) (total : Nat)
+    (payoff : List α → ENNReal) (consumed : List α) (left right : ENNReal) :
+    terminalProposalPotential base total (fun word => left * payoff word * right) consumed =
+      left * terminalProposalPotential base total payoff consumed * right := by
+  unfold terminalProposalPotential
+  calc
+    _ = ∑' word, (left * (Pr[= word | completeProposalWord base total consumed] * payoff word)) * right := by
+      apply tsum_congr
+      intro word
+      ring
+    _ = _ := by rw [ENNReal.tsum_mul_right, ENNReal.tsum_mul_left]
+
+theorem targetProposalPrefix_length_le (completed total : Nat) (consumed : List Index)
+    (hcompleted : completed ≤ signatureLimit) (htotal : 25313293 ≤ total)
+    (hprefix : (consumed.length : ENNReal) ≤ targetProposalOverhead * completed + 131072) :
+    consumed.length ≤ total := by
+  apply (Nat.cast_le (α := ENNReal)).mp
+  calc
+    _ ≤ targetProposalOverhead * completed + 131072 := hprefix
+    _ ≤ targetProposalOverhead * signatureLimit + 131072 :=
+      add_le_add (mul_le_mul' le_rfl (Nat.cast_le.mpr hcompleted)) le_rfl
+    _ ≤ targetProposalOverhead * signatureLimit + 131072 + 13 := le_self_add
+    _ = (25313293 : ENNReal) := targetProposalPoolMinimum_eq
+    _ ≤ (total : ENNReal) := by exact_mod_cast htotal
+
+theorem reuseRawEnvelope_le_terminalProposalPotential (key : SecretKey)
+    (spent queries completed total : Nat) (state : CoverLogState) (required : Finset FtsTree)
+    (consumed : List Index) (hqueries : spent + queries ≤ 2 ^ 127)
+    (hcompleted : completed ≤ signatureLimit)
+    (hcache : ∀ index : Index, cachedIndexMultiplicity key.parameter state.1 index ≤
+      (spent : ENNReal) * ((2 ^ 36 : Nat) : ENNReal)⁻¹ + ((2 ^ 80 : Nat) : ENNReal))
+    (hcounts : ∀ index : Index,
+      (signingSlotsAtIndex (observedOptionalSigningViews
+        (FtsProbeSimulation.messageAnswers key.parameter state.1) key.root state.2) index).card ≤ consumed.count index)
+    (htotal : 25313293 ≤ total)
+    (hprefix : (consumed.length : ENNReal) ≤ targetProposalOverhead * completed + 131072) :
+    reuseRawEnvelope key nearUniformDigestReuseWeight queries (signatureLimit - completed) state ∅ required ≤
+      terminalProposalPotential (PMF.uniformOfFintype Index) total
+        (fun word => ∑ index : Index, (word.count index : ENNReal) ^ required.card) consumed := by
+  rw [terminalProposalPotential_eq_uniform_suffix total consumed
+    (targetProposalPrefix_length_le completed total consumed hcompleted htotal hprefix)]
+  exact reuseRawEnvelope_le_expected_terminalProposalWord key spent queries completed total state required consumed
+    hqueries hcompleted hcache hcounts htotal hprefix
+
+theorem targetCreationPrice_le_terminalProposalPotential (key : SecretKey)
+    (spent queries completed total : Nat) (state : CoverLogState) (required : Finset FtsTree)
+    (consumed : List Index) (hqueries : spent + queries ≤ 2 ^ 127)
+    (hcompleted : completed ≤ signatureLimit)
+    (hcache : ∀ index : Index, cachedIndexMultiplicity key.parameter state.1 index ≤
+      (spent : ENNReal) * ((2 ^ 36 : Nat) : ENNReal)⁻¹ + ((2 ^ 80 : Nat) : ENNReal))
+    (hcounts : ∀ index : Index,
+      (signingSlotsAtIndex (observedOptionalSigningViews
+        (FtsProbeSimulation.messageAnswers key.parameter state.1) key.root state.2) index).card ≤ consumed.count index)
+    (htotal : 25313293 ≤ total)
+    (hprefix : (consumed.length : ENNReal) ≤ targetProposalOverhead * completed + 131072) :
+    targetCreationPrice key nearUniformDigestReuseWeight queries (signatureLimit - completed) required state ≤
+      terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice required) consumed := by
+  unfold terminalCertificatePrice
+  rw [targetCreationPrice, terminalProposalPotential_scale]
+  exact mul_le_mul' (mul_le_mul' le_rfl
+    (reuseRawEnvelope_le_terminalProposalPotential key spent queries completed total state required consumed
+      hqueries hcompleted hcache hcounts htotal hprefix)) le_rfl
+
+theorem certificateMonitorCharge_le_terminalPrice (key : SecretKey) (budget total : Nat)
+    (required : Finset FtsTree) (input : (OracleWorld + SigningSpec).Domain)
+    (state : CertificateMonitorState) (consumed : List Index) (hbudget : budget ≤ 2 ^ 127)
+    (hcompleted : state.2.log.length ≤ signatureLimit)
+    (hcounts : ∀ index : Index,
+      (signingSlotsAtIndex (observedOptionalSigningViews
+        (FtsProbeSimulation.messageAnswers key.parameter state.1) key.root state.2.log) index).card ≤ consumed.count index)
+    (htotal : 25313293 ≤ total)
+    (hprefix : (consumed.length : ENNReal) ≤ targetProposalOverhead * state.2.log.length + 131072) :
+    certificateMonitorCharge key budget required input state ≤
+      certificateMonitorMass key budget input state *
+        terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice required) consumed := by
+  classical
+  by_cases hactive : CertificateMonitorActive key budget input state
+  · rw [certificateMonitorCharge, certificateMonitorMass, if_pos hactive, if_pos hactive]
+    apply mul_le_mul' le_rfl
+    have hspent : state.2.spent ≤ budget := hactive.2.1.2.2
+    exact targetCreationPrice_le_terminalProposalPotential key state.2.spent (budget - state.2.spent)
+      state.2.log.length total (certificateMonitorCoverState state) required consumed (by omega)
+      hcompleted hactive.2.1.2.1.index_le hcounts htotal hprefix
+  · simp only [certificateMonitorCharge, certificateMonitorMass, if_neg hactive, zero_mul, le_refl]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/TerminalProposalWord.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/TerminalProposalWord.lean
new file mode 100644
index 000000000..e3080e85b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/TerminalProposalWord.lean
@@ -0,0 +1,79 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.ProposalBridgeKernel
+namespace SphincsSecurity.Concrete
+
+open ENNReal
+
+noncomputable def completeProposalWord {α : Type*} (base : PMF α) : Nat → List α → PMF (List α)
+  | 0, _ => PMF.pure []
+  | total + 1, [] => independentProposalWord base (total + 1)
+  | total + 1, head :: rest => (completeProposalWord base total rest).map (head :: ·)
+
+theorem completeProposalWord_nil {α : Type*} (base : PMF α) (total : Nat) :
+    completeProposalWord base total [] = independentProposalWord base total := by
+  cases total <;> rfl
+
+theorem completeProposalWord_eq_padding {α : Type*} (base : PMF α) (total : Nat) (consumed : List α) :
+    completeProposalWord base total consumed =
+      (independentProposalWord base (total - consumed.length)).map (fun word => consumed.take total ++ word) := by
+  induction consumed generalizing total with
+  | nil =>
+      simp only [completeProposalWord_nil, List.length_nil, Nat.sub_zero, List.take_nil, List.nil_append]
+      exact (PMF.map_id _).symm
+  | cons head rest ih =>
+      cases total with
+      | zero => simp only [completeProposalWord, Nat.zero_sub, independentProposalWord,
+          PMF.monad_pure_eq_pure, PMF.pure_map, List.take_zero, List.nil_append]
+      | succ total =>
+          rw [completeProposalWord, ih, PMF.map_comp]
+          simp only [List.length_cons, Nat.succ_sub_succ_eq_sub, List.take_succ_cons]
+          rfl
+
+theorem complete_cappedRecordProposalBridge {α Ω : Type*} (base : PMF α) (record : PMF Ω) (label : Ω → α)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hlt : accept < 1)
+    (hcap : ∀ index, accept * (record.map label) index ≤ base index) (total : Nat) :
+    (cappedRecordProposalBridge base record label accept hpos hlt hcap).bind
+        (fun result => completeProposalWord base total (result.1 ++ [label result.2])) =
+      independentProposalWord base total := by
+  induction total with
+  | zero => simp only [completeProposalWord, PMF.bind_const, independentProposalWord, PMF.monad_pure_eq_pure]
+  | succ total ih =>
+      rw [cappedRecordProposalBridge_step, PMF.bind_bind]
+      have hbranch (branch : α ⊕ Ω) :
+          (proposalBridgeContinuation (cappedRecordProposalBridge base record label accept hpos hlt hcap) branch).bind
+              (fun result => completeProposalWord base (total + 1) (result.1 ++ [label result.2])) =
+            (independentProposalWord base total).map (Sum.elim id label branch :: ·) := by
+        cases branch with
+        | inl head =>
+            rw [proposalBridgeContinuation, PMF.bind_map]
+            change (cappedRecordProposalBridge base record label accept hpos hlt hcap).bind
+                (fun result => (completeProposalWord base total (result.1 ++ [label result.2])).map (head :: ·)) = _
+            rw [← PMF.map_bind, ih]
+            rfl
+        | inr outcome =>
+            simp only [proposalBridgeContinuation, PMF.pure_bind, List.nil_append,
+              completeProposalWord, completeProposalWord_nil, Sum.elim_inr]
+      simp_rw [hbranch]
+      change (proposalRecordStep base record label accept hlt hcap).bind
+          ((fun index => (independentProposalWord base total).map (index :: ·)) ∘ Sum.elim id label) = _
+      rw [← PMF.bind_map, proposalRecordStep_label]
+      rfl
+
+theorem complete_cappedRecordProposalBridge_prefix {α Ω : Type*} (base : PMF α) (record : PMF Ω) (label : Ω → α)
+    (accept : ENNReal) (hpos : accept ≠ 0) (hlt : accept < 1)
+    (hcap : ∀ index, accept * (record.map label) index ≤ base index) (total : Nat) (consumed : List α) :
+    (cappedRecordProposalBridge base record label accept hpos hlt hcap).bind
+        (fun result => completeProposalWord base total (consumed ++ (result.1 ++ [label result.2]))) =
+      completeProposalWord base total consumed := by
+  induction consumed generalizing total with
+  | nil =>
+      simpa only [List.nil_append, completeProposalWord_nil] using
+        complete_cappedRecordProposalBridge base record label accept hpos hlt hcap total
+  | cons head rest ih =>
+      cases total with
+      | zero => simp only [completeProposalWord, PMF.bind_const]
+      | succ total =>
+          simp only [List.cons_append, completeProposalWord]
+          rw [← PMF.map_bind, ih]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/UniformProposalMixedMoments.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/UniformProposalMixedMoments.lean
new file mode 100644
index 000000000..c884c6675
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/UniformProposalMixedMoments.lean
@@ -0,0 +1,223 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.UniformProposalMoments
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp ENNReal
+
+noncomputable def uniformWordAverage {α : Type} [SampleableType α]
+    (steps : Nat) (payoff : List α → ENNReal) : ENNReal :=
+  ∑' word, Pr[= word | sampleUniformProposalWord α steps] * payoff word
+
+theorem uniformWordAverage_add {α : Type} [SampleableType α]
+    (steps : Nat) (first second : List α → ENNReal) :
+    uniformWordAverage steps (fun word => first word + second word) =
+      uniformWordAverage steps first + uniformWordAverage steps second := by
+  simp only [uniformWordAverage, mul_add, ENNReal.tsum_add]
+
+theorem uniformWordAverage_mul_left {α : Type} [SampleableType α]
+    (steps : Nat) (factor : ENNReal) (payoff : List α → ENNReal) :
+    uniformWordAverage steps (fun word => factor * payoff word) =
+      factor * uniformWordAverage steps payoff := by
+  simp only [uniformWordAverage, mul_left_comm _ factor, ENNReal.tsum_mul_left]
+
+theorem uniformWordAverage_sum {α β : Type} [SampleableType α]
+    (steps : Nat) (set : Finset β) (payoff : β → List α → ENNReal) :
+    uniformWordAverage steps (fun word => ∑ index ∈ set, payoff index word) =
+      ∑ index ∈ set, uniformWordAverage steps (payoff index) := by
+  simp only [uniformWordAverage, Finset.mul_sum]
+  exact Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)
+
+theorem uniformWordAverage_count_descFactorial {α : Type} [SampleableType α]
+    [Fintype α] [DecidableEq α] (index : α) (steps degree : Nat) :
+    uniformWordAverage steps (fun word : List α => (word.count index).descFactorial degree) =
+      (steps.descFactorial degree : ENNReal) * (Fintype.card α : ENNReal)⁻¹ ^ degree := by
+  letI : Nonempty α := ⟨index⟩
+  rw [uniformWordAverage, expected_uniformProposalWord_count index steps
+    (fun count => (count.descFactorial degree : ENNReal))]
+  exact binomialAverage_descFactorial (ENNReal.inv_le_one.mpr (by exact_mod_cast Fintype.card_pos)) steps degree
+
+theorem descFactorial_succ_add (count degree : Nat) :
+    (count + 1).descFactorial (degree + 1) =
+      count.descFactorial (degree + 1) + (degree + 1) * count.descFactorial degree := by
+  rw [Nat.succ_descFactorial_succ]
+  calc
+    _ = count * count.descFactorial degree + count.descFactorial degree := by ring
+    _ = _ := by rw [mul_descFactorial_eq]; ring
+
+private theorem expected_uniformSample_two_increments {α : Type} [SampleableType α]
+    [Fintype α] [DecidableEq α] (first second : α) (base left right : ENNReal) :
+    (∑' next : α, Pr[= next | ($ᵗ α : ProbComp α)] *
+      (base + (if next = first then left else 0) + (if next = second then right else 0))) =
+      base + (Fintype.card α : ENNReal)⁻¹ * left + (Fintype.card α : ENNReal)⁻¹ * right := by
+  simp only [mul_add, ENNReal.tsum_add, mul_ite, mul_zero]
+  rw [ENNReal.tsum_mul_right, tsum_probOutput_eq_sub, probFailure_uniformSample, tsub_zero, one_mul]
+  simp only [tsum_ite_eq, probOutput_uniformSample]
+
+theorem uniformWordAverage_mixed_descFactorial {α : Type} [SampleableType α]
+    [Fintype α] [DecidableEq α] (first second : α) (hdistinct : first ≠ second)
+    (steps left right : Nat) :
+    uniformWordAverage steps (fun word : List α =>
+      ((word.count first).descFactorial left : ENNReal) * (word.count second).descFactorial right) =
+      (steps.descFactorial (left + right) : ENNReal) * (Fintype.card α : ENNReal)⁻¹ ^ (left + right) := by
+  induction steps generalizing left right with
+  | zero =>
+      cases left <;> cases right <;>
+        simp [uniformWordAverage, sampleUniformProposalWord]
+  | succ steps ih =>
+      cases left with
+      | zero =>
+          simpa only [Nat.descFactorial_zero, Nat.cast_one, one_mul, Nat.zero_add] using
+            uniformWordAverage_count_descFactorial second (steps + 1) right
+      | succ left =>
+          cases right with
+          | zero =>
+              simpa only [Nat.descFactorial_zero, Nat.cast_one, mul_one, Nat.add_zero] using
+                uniformWordAverage_count_descFactorial first (steps + 1) (left + 1)
+          | succ right =>
+              have hpoint (word : List α) (next : α) :
+                  (((next :: word).count first).descFactorial (left + 1) : ENNReal) *
+                    ((next :: word).count second).descFactorial (right + 1) =
+                  ((word.count first).descFactorial (left + 1) : ENNReal) *
+                    (word.count second).descFactorial (right + 1) +
+                  (if next = first then (left + 1 : ENNReal) *
+                    ((word.count first).descFactorial left * (word.count second).descFactorial (right + 1)) else 0) +
+                  (if next = second then (right + 1 : ENNReal) *
+                    ((word.count first).descFactorial (left + 1) * (word.count second).descFactorial right) else 0) := by
+                by_cases hfirst : next = first
+                · subst next
+                  simp only [List.count_cons_self, List.count_cons_of_ne hdistinct,
+                    descFactorial_succ_add, Nat.cast_add, Nat.cast_mul, Nat.cast_one,
+                    ↓reduceIte, if_neg hdistinct, add_zero]
+                  ring
+                · by_cases hsecond : next = second
+                  · subst next
+                    simp only [List.count_cons_self, List.count_cons_of_ne hfirst,
+                      descFactorial_succ_add, Nat.cast_add, Nat.cast_mul, Nat.cast_one,
+                      ↓reduceIte, if_neg hfirst, add_zero]
+                    ring
+                  · simp only [List.count_cons_of_ne hfirst, List.count_cons_of_ne hsecond,
+                      if_neg hfirst, if_neg hsecond, add_zero]
+              rw [uniformWordAverage, sampleUniformProposalWord, tsum_probOutput_bind_mul]
+              simp_rw [tsum_probOutput_bind_mul, tsum_probOutput_pure_mul]
+              simp_rw [← ENNReal.tsum_mul_left]
+              rw [ENNReal.tsum_comm]
+              simp_rw [← mul_assoc]
+              have hreorder :
+                  (∑' word : List α, ∑' next : α, Pr[= next | ($ᵗ α : ProbComp α)] *
+                    Pr[= word | sampleUniformProposalWord α steps] *
+                    (((next :: word).count first).descFactorial (left + 1) : ENNReal) *
+                    ((next :: word).count second).descFactorial (right + 1)) =
+                  uniformWordAverage steps (fun word : List α =>
+                    ((word.count first).descFactorial (left + 1) : ENNReal) *
+                      (word.count second).descFactorial (right + 1) +
+                    (Fintype.card α : ENNReal)⁻¹ * (left + 1) *
+                      ((word.count first).descFactorial left * (word.count second).descFactorial (right + 1)) +
+                    (Fintype.card α : ENNReal)⁻¹ * (right + 1) *
+                      ((word.count first).descFactorial (left + 1) * (word.count second).descFactorial right)) := by
+                unfold uniformWordAverage
+                apply tsum_congr
+                intro word
+                calc
+                  _ = Pr[= word | sampleUniformProposalWord α steps] * ∑' next : α,
+                      Pr[= next | ($ᵗ α : ProbComp α)] *
+                        ((((next :: word).count first).descFactorial (left + 1) : ENNReal) *
+                          ((next :: word).count second).descFactorial (right + 1)) := by
+                    rw [← ENNReal.tsum_mul_left]
+                    apply tsum_congr
+                    intro next
+                    ring
+                  _ = _ := by
+                    simp_rw [hpoint, expected_uniformSample_two_increments]
+                    ring
+              rw [hreorder, uniformWordAverage_add, uniformWordAverage_add,
+                uniformWordAverage_mul_left, uniformWordAverage_mul_left, ih, ih, ih]
+              have hdegree : left + 1 + (right + 1) = (left + right + 1) + 1 := by omega
+              rw [hdegree, descFactorial_succ_add]
+              simp only [Nat.cast_add, Nat.cast_mul, Nat.cast_one, pow_succ]
+              have hexp : left + (right + 1) = left + right + 1 := by omega
+              simp only [hexp, Nat.add_right_comm left 1 right, pow_succ]
+              ring
+
+theorem descFactorial_add_le_mul (steps left right : Nat) :
+    steps.descFactorial (left + right) ≤ steps.descFactorial left * steps.descFactorial right := by
+  have h := Nat.descFactorial_mul_descFactorial (n := steps) (k := left) (m := left + right)
+    (Nat.le_add_right left right)
+  rw [Nat.add_sub_cancel_left] at h
+  rw [← h, Nat.mul_comm]
+  exact Nat.mul_le_mul_left _ (Nat.descFactorial_le right (Nat.sub_le steps left))
+
+theorem uniformWordAverage_mixed_descFactorial_le_product {α : Type} [SampleableType α]
+    [Fintype α] [DecidableEq α] (first second : α) (hdistinct : first ≠ second)
+    (steps left right : Nat) :
+    uniformWordAverage steps (fun word : List α =>
+      ((word.count first).descFactorial left : ENNReal) * (word.count second).descFactorial right) ≤
+      uniformWordAverage steps (fun word : List α => (word.count first).descFactorial left) *
+        uniformWordAverage steps (fun word : List α => (word.count second).descFactorial right) := by
+  rw [uniformWordAverage_mixed_descFactorial first second hdistinct,
+    uniformWordAverage_count_descFactorial, uniformWordAverage_count_descFactorial]
+  calc
+    _ ≤ ((steps.descFactorial left : ENNReal) * steps.descFactorial right) *
+        (Fintype.card α : ENNReal)⁻¹ ^ (left + right) := by
+      apply mul_le_mul' _ le_rfl
+      exact_mod_cast descFactorial_add_le_mul steps left right
+    _ = _ := by rw [pow_add]; ring
+
+theorem uniformWordAverage_mono {α : Type} [SampleableType α]
+    (steps : Nat) {first second : List α → ENNReal} (hle : ∀ word, first word ≤ second word) :
+    uniformWordAverage steps first ≤ uniformWordAverage steps second :=
+  ENNReal.tsum_le_tsum fun word => mul_le_mul' le_rfl (hle word)
+
+theorem uniformWordAverage_mixed_power_le_product {α : Type} [SampleableType α]
+    [Fintype α] [DecidableEq α] (first second : α) (hdistinct : first ≠ second)
+    (steps left right : Nat) :
+    uniformWordAverage steps (fun word : List α => (word.count first : ENNReal) ^ left *
+      (word.count second : ENNReal) ^ right) ≤
+      uniformWordAverage steps (fun word : List α => (word.count first : ENNReal) ^ left) *
+        uniformWordAverage steps (fun word : List α => (word.count second : ENNReal) ^ right) := by
+  have hpower (count degree : Nat) : (count : ENNReal) ^ degree =
+      ∑ order ∈ Finset.range (degree + 1),
+        (Nat.stirlingSecond degree order : ENNReal) * count.descFactorial order := by
+    exact_mod_cast power_eq_stirling_descFactorial count degree
+  simp_rw [hpower, Finset.sum_mul, Finset.mul_sum, uniformWordAverage_sum]
+  rw [Finset.sum_mul]
+  simp_rw [Finset.mul_sum]
+  apply Finset.sum_le_sum
+  intro a _
+  apply Finset.sum_le_sum
+  intro b _
+  have hfactor :
+      (fun word : List α =>
+        ((Nat.stirlingSecond left a : ENNReal) * (word.count first).descFactorial a) *
+          ((Nat.stirlingSecond right b : ENNReal) * (word.count second).descFactorial b)) =
+      (fun word : List α =>
+        ((Nat.stirlingSecond left a : ENNReal) * Nat.stirlingSecond right b) *
+          ((word.count first).descFactorial a * (word.count second).descFactorial b)) := by
+    funext word
+    ring
+  rw [hfactor, uniformWordAverage_mul_left, uniformWordAverage_mul_left, uniformWordAverage_mul_left]
+  exact (mul_le_mul' le_rfl
+    (uniformWordAverage_mixed_descFactorial_le_product first second hdistinct steps a b)).trans_eq (by ring)
+
+noncomputable def stirlingPowerMoment (rate : ENNReal) (degree : Nat) : ENNReal :=
+  ∑ order ∈ Finset.range (degree + 1), (Nat.stirlingSecond degree order : ENNReal) * rate ^ order
+
+theorem uniformWordAverage_power_le_stirling {α : Type} [SampleableType α]
+    [Fintype α] [DecidableEq α] (index : α) (steps degree : Nat) (rate : ENNReal)
+    (hrate : (steps : ENNReal) * (Fintype.card α : ENNReal)⁻¹ ≤ rate) :
+    uniformWordAverage steps (fun word : List α => (word.count index : ENNReal) ^ degree) ≤
+      stirlingPowerMoment rate degree := by
+  letI : Nonempty α := ⟨index⟩
+  rw [uniformWordAverage, expected_uniformProposalWord_count index steps (fun count => (count : ENNReal) ^ degree),
+    binomialAverage_power (ENNReal.inv_le_one.mpr (by exact_mod_cast Fintype.card_pos))]
+  apply Finset.sum_le_sum
+  intro order _
+  calc
+    _ ≤ (Nat.stirlingSecond degree order : ENNReal) * (steps : ENNReal) ^ order *
+        (Fintype.card α : ENNReal)⁻¹ ^ order := by
+      apply mul_le_mul' (mul_le_mul' le_rfl _) le_rfl
+      exact_mod_cast Nat.descFactorial_le_pow steps order
+    _ = (Nat.stirlingSecond degree order : ENNReal) *
+        ((steps : ENNReal) * (Fintype.card α : ENNReal)⁻¹) ^ order := by rw [mul_pow]; ring
+    _ ≤ _ := mul_le_mul' le_rfl (pow_le_pow_left' hrate order)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/UniformProposalMoments.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/UniformProposalMoments.lean
new file mode 100644
index 000000000..68ef874b0
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/UniformProposalMoments.lean
@@ -0,0 +1,148 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.RawProposalMomentBound
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp ENNReal
+
+noncomputable def sampleUniformProposalWord (α : Type) [SampleableType α] : Nat → ProbComp (List α)
+  | 0 => pure []
+  | steps + 1 => do
+      let next ← $ᵗ α
+      let rest ← sampleUniformProposalWord α steps
+      pure (next :: rest)
+
+theorem expected_uniformSample_choice {α : Type} [SampleableType α] [Fintype α] [DecidableEq α]
+    (index : α) (hit miss : ENNReal) :
+    (∑' next : α, Pr[= next | ($ᵗ α : ProbComp α)] * (if next = index then hit else miss)) =
+      (1 - (Fintype.card α : ENNReal)⁻¹) * miss + (Fintype.card α : ENNReal)⁻¹ * hit := by
+  classical
+  have hmiss : Pr[fun next => next ≠ index | ($ᵗ α : ProbComp α)] =
+      1 - (Fintype.card α : ENNReal)⁻¹ := by
+    apply ENNReal.eq_sub_of_add_eq' (by finiteness)
+    have h := probEvent_compl ($ᵗ α : ProbComp α) (fun next => next = index)
+    simpa only [probEvent_eq_eq_probOutput, probOutput_uniformSample, probFailure_uniformSample, tsub_zero,
+      add_comm] using h
+  calc
+    _ = (∑' next : α, (if next = index then Pr[= next | ($ᵗ α : ProbComp α)] else 0)) * hit +
+        (∑' next : α, (if next ≠ index then Pr[= next | ($ᵗ α : ProbComp α)] else 0)) * miss := by
+      rw [← ENNReal.tsum_mul_right, ← ENNReal.tsum_mul_right, ← ENNReal.tsum_add]
+      apply tsum_congr
+      intro next
+      by_cases h : next = index <;> simp [h]
+    _ = _ := by
+      rw [← probEvent_eq_tsum_ite, ← probEvent_eq_tsum_ite, probEvent_eq_eq_probOutput,
+        probOutput_uniformSample, hmiss, add_comm]
+
+theorem expected_uniformProposalWord_count {α : Type} [SampleableType α] [Fintype α] [DecidableEq α]
+    (index : α) (steps : Nat) (f : Nat → ENNReal) :
+    (∑' word : List α, Pr[= word | sampleUniformProposalWord α steps] * f (word.count index)) =
+      binomialAverage (Fintype.card α : ENNReal)⁻¹ steps f := by
+  induction steps generalizing f with
+  | zero => simp only [sampleUniformProposalWord, tsum_probOutput_pure_mul, List.count_nil, binomialAverage_zero]
+  | succ steps ih =>
+      rw [sampleUniformProposalWord, tsum_probOutput_bind_mul]
+      simp_rw [tsum_probOutput_bind_mul, tsum_probOutput_pure_mul]
+      have hinner (next : α) :
+          (∑' word : List α, Pr[= word | sampleUniformProposalWord α steps] * f ((next :: word).count index)) =
+            if next = index then binomialAverage (Fintype.card α : ENNReal)⁻¹ steps (fun count => f (count + 1))
+              else binomialAverage (Fintype.card α : ENNReal)⁻¹ steps f := by
+        by_cases h : next = index
+        · subst next
+          simpa only [List.count_cons_self, ↓reduceIte] using ih (fun count => f (count + 1))
+        · simpa only [List.count_cons_of_ne h, if_neg h] using ih f
+      simp_rw [hinner]
+      exact expected_uniformSample_choice index _ _
+
+theorem expected_uniformProposalWord_power_sum {α : Type} [SampleableType α] [Fintype α] [DecidableEq α]
+    (steps degree : Nat) (consumed : α → Nat) :
+    (∑' word : List α, Pr[= word | sampleUniformProposalWord α steps] *
+      ∑ index : α, ((consumed index : ENNReal) + word.count index) ^ degree) =
+      ∑ index : α, binomialAverage (Fintype.card α : ENNReal)⁻¹ steps
+        (fun count => ((consumed index : ENNReal) + count) ^ degree) := by
+  simp only [Finset.mul_sum]
+  rw [Summable.tsum_finsetSum (fun _ _ => ENNReal.summable)]
+  apply Finset.sum_congr rfl
+  intro index _
+  exact expected_uniformProposalWord_count index steps (fun count => ((consumed index : ENNReal) + count) ^ degree)
+
+theorem reuseRawEnvelope_le_expected_uniformProposalWord (key : SecretKey)
+    (spent queries signatures bound proposals : Nat) (state : CoverLogState) (remaining : Finset FtsTree)
+    (consumed : Index → Nat) (hqueries : spent + queries ≤ 2 ^ 127) (hsignatures : signatures ≤ signatureLimit)
+    (hdegree : remaining.card ≤ bound) (hbound : bound ≤ 14)
+    (hcache : ∀ index : Index, cachedIndexMultiplicity key.parameter state.1 index ≤
+      (spent : ENNReal) * ((2 ^ 36 : Nat) : ENNReal)⁻¹ + ((2 ^ 80 : Nat) : ENNReal))
+    (hcounts : ∀ index : Index,
+      (signingSlotsAtIndex (observedOptionalSigningViews
+        (FtsProbeSimulation.messageAnswers key.parameter state.1) key.root state.2) index).card ≤ consumed index)
+    (hroom : targetProposalOverhead * signatures + remaining.card ≤ ((proposals + 1 : Nat) : ENNReal)) :
+    reuseRawEnvelope key nearUniformDigestReuseWeight queries signatures state ∅ remaining ≤
+      ∑' word : List Index, Pr[= word | sampleUniformProposalWord Index proposals] *
+        ∑ index : Index, ((consumed index : ENNReal) + word.count index) ^ remaining.card := by
+  rw [expected_uniformProposalWord_power_sum]
+  exact reuseRawEnvelope_le_uniformProposalAverage key spent queries signatures bound proposals state remaining
+    consumed hqueries hsignatures hdegree hbound hcache hcounts hroom
+
+theorem targetProposalRoom_of_prefix (completed signatures total used degree slack : Nat)
+    (hsignatures : completed + signatures ≤ signatureLimit) (hdegree : degree ≤ 14)
+    (htotal : targetProposalOverhead * signatureLimit + slack + 13 ≤ (total : ENNReal))
+    (hused : (used : ENNReal) ≤ targetProposalOverhead * completed + slack) :
+    targetProposalOverhead * signatures + degree ≤ ((total - used + 1 : Nat) : ENNReal) := by
+  have hcompleted : completed ≤ signatureLimit := (Nat.le_add_right completed signatures).trans hsignatures
+  have husedTotal : used ≤ total := by
+    apply (Nat.cast_le (α := ENNReal)).mp
+    exact hused.trans ((add_le_add (mul_le_mul' le_rfl (Nat.cast_le.mpr hcompleted)) le_rfl).trans
+      ((le_self_add : targetProposalOverhead * signatureLimit + slack ≤
+        targetProposalOverhead * signatureLimit + slack + 13).trans htotal))
+  have hcapacity : (used : ENNReal) + (targetProposalOverhead * signatures + degree) ≤ (total : ENNReal) + 1 := by
+    calc
+      _ ≤ targetProposalOverhead * completed + slack + (targetProposalOverhead * signatures + degree) :=
+        add_le_add hused le_rfl
+      _ = targetProposalOverhead * ((completed + signatures : Nat) : ENNReal) + slack + degree := by
+        push_cast
+        ring
+      _ ≤ targetProposalOverhead * signatureLimit + slack + 14 :=
+        add_le_add (add_le_add (mul_le_mul' le_rfl (Nat.cast_le.mpr hsignatures)) le_rfl)
+          (by exact_mod_cast hdegree)
+      _ = (targetProposalOverhead * signatureLimit + slack + 13) + 1 := by ring
+      _ ≤ _ := add_le_add htotal le_rfl
+  have hsum : ((total - used + 1 : Nat) : ENNReal) + (used : ENNReal) = (total : ENNReal) + 1 := by
+    exact_mod_cast (show total - used + 1 + used = total + 1 by omega)
+  apply ENNReal.le_of_add_le_add_right (a := (used : ENNReal)) (by finiteness)
+  calc
+    _ = (used : ENNReal) + (targetProposalOverhead * signatures + degree) := add_comm _ _
+    _ ≤ (total : ENNReal) + 1 := hcapacity
+    _ = _ := hsum.symm
+
+theorem targetProposalPoolMinimum_eq :
+    targetProposalOverhead * signatureLimit + 131072 + 13 = (25313293 : ENNReal) := by
+  unfold targetProposalOverhead
+  apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp
+  simp (disch := finiteness) only [ENNReal.toReal_add, ENNReal.toReal_mul, ENNReal.toReal_div]
+  norm_num [signatureLimit]
+
+theorem reuseRawEnvelope_le_expected_terminalProposalWord (key : SecretKey)
+    (spent queries completed total : Nat) (state : CoverLogState) (remaining : Finset FtsTree)
+    (consumedWord : List Index) (hqueries : spent + queries ≤ 2 ^ 127) (hcompleted : completed ≤ signatureLimit)
+    (hcache : ∀ index : Index, cachedIndexMultiplicity key.parameter state.1 index ≤
+      (spent : ENNReal) * ((2 ^ 36 : Nat) : ENNReal)⁻¹ + ((2 ^ 80 : Nat) : ENNReal))
+    (hcounts : ∀ index : Index,
+      (signingSlotsAtIndex (observedOptionalSigningViews
+        (FtsProbeSimulation.messageAnswers key.parameter state.1) key.root state.2) index).card ≤ consumedWord.count index)
+    (htotal : 25313293 ≤ total)
+    (hprefix : (consumedWord.length : ENNReal) ≤ targetProposalOverhead * completed + 131072) :
+    reuseRawEnvelope key nearUniformDigestReuseWeight queries (signatureLimit - completed) state ∅ remaining ≤
+      ∑' word : List Index, Pr[= word | sampleUniformProposalWord Index (total - consumedWord.length)] *
+        ∑ index : Index, ((consumedWord ++ word).count index : ENNReal) ^ remaining.card := by
+  have hdegree : remaining.card ≤ 14 := by
+    exact (Finset.card_le_univ remaining).trans_eq (by decide : Fintype.card FtsTree = 14)
+  have hroom : targetProposalOverhead * (signatureLimit - completed : Nat) + remaining.card ≤
+      ((total - consumedWord.length + 1 : Nat) : ENNReal) :=
+    targetProposalRoom_of_prefix completed (signatureLimit - completed) total consumedWord.length remaining.card 131072
+      (by omega) hdegree
+      (by norm_num only [Nat.cast_ofNat]; rw [targetProposalPoolMinimum_eq]; exact_mod_cast htotal) hprefix
+  have h := reuseRawEnvelope_le_expected_uniformProposalWord key spent queries (signatureLimit - completed) 14
+    (total - consumedWord.length) state remaining (fun index => consumedWord.count index) hqueries (Nat.sub_le _ _)
+    hdegree le_rfl hcache hcounts hroom
+  simpa only [List.count_append, Nat.cast_add] using h
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/UniformProposalVariance.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/UniformProposalVariance.lean
new file mode 100644
index 000000000..20a2135c6
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/UniformProposalVariance.lean
@@ -0,0 +1,72 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.UniformProposalMixedMoments
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp ENNReal
+
+theorem uniformWordAverage_sum_square_le {α β : Type} [SampleableType α] [Fintype β] [DecidableEq β]
+    (steps : Nat) (payoff : β → List α → ENNReal)
+    (hcross : ∀ first second, first ≠ second →
+      uniformWordAverage steps (fun word => payoff first word * payoff second word) ≤
+        uniformWordAverage steps (payoff first) * uniformWordAverage steps (payoff second)) :
+    uniformWordAverage steps (fun word => (∑ index, payoff index word) ^ 2) ≤
+      (∑ index, uniformWordAverage steps (payoff index)) ^ 2 +
+        ∑ index, uniformWordAverage steps (fun word => payoff index word ^ 2) := by
+  calc
+    _ = ∑ first, ∑ second, uniformWordAverage steps
+        (fun word => payoff first word * payoff second word) := by
+      simp only [pow_two, Finset.sum_mul, Finset.mul_sum, uniformWordAverage_sum]
+      exact Finset.sum_comm
+    _ ≤ ∑ first, ∑ second,
+        (uniformWordAverage steps (payoff first) * uniformWordAverage steps (payoff second) +
+          if second = first then uniformWordAverage steps (fun word => payoff first word ^ 2) else 0) := by
+      apply Finset.sum_le_sum
+      intro first _
+      apply Finset.sum_le_sum
+      intro second _
+      by_cases heq : first = second
+      · subst second
+        simp only [↓reduceIte, pow_two]
+        exact le_add_self
+      · simpa only [if_neg (Ne.symm heq), add_zero] using hcross first second heq
+    _ = _ := by
+      simp only [Finset.sum_add_distrib, Finset.sum_ite_eq', Finset.mem_univ, ↓reduceIte,
+        pow_two, Finset.sum_mul, Finset.mul_sum]
+      congr 1
+      exact Finset.sum_comm
+
+noncomputable def proposalPowerSum {α : Type} [Fintype α] [DecidableEq α]
+    (degree : Nat) (word : List α) : ENNReal :=
+  ∑ index : α, (word.count index : ENNReal) ^ degree
+
+theorem uniformWordAverage_powerSum_le {α : Type} [SampleableType α] [Fintype α] [DecidableEq α]
+    (steps degree : Nat) (rate : ENNReal)
+    (hrate : (steps : ENNReal) * (Fintype.card α : ENNReal)⁻¹ ≤ rate) :
+    uniformWordAverage steps (proposalPowerSum (α := α) degree) ≤
+      (Fintype.card α : ENNReal) * stirlingPowerMoment rate degree := by
+  unfold proposalPowerSum
+  rw [uniformWordAverage_sum]
+  calc
+    _ ≤ ∑ _index : α, stirlingPowerMoment rate degree :=
+      Finset.sum_le_sum fun index _ => uniformWordAverage_power_le_stirling index steps degree rate hrate
+    _ = _ := by simp only [Finset.sum_const, Finset.card_univ, nsmul_eq_mul]
+
+theorem uniformWordAverage_powerSum_square_le {α : Type} [SampleableType α] [Fintype α] [DecidableEq α]
+    (steps degree : Nat) (rate : ENNReal)
+    (hrate : (steps : ENNReal) * (Fintype.card α : ENNReal)⁻¹ ≤ rate) :
+    uniformWordAverage steps (fun word => proposalPowerSum (α := α) degree word ^ 2) ≤
+      uniformWordAverage steps (proposalPowerSum (α := α) degree) ^ 2 +
+        (Fintype.card α : ENNReal) * stirlingPowerMoment rate (degree * 2) := by
+  have h := uniformWordAverage_sum_square_le steps
+    (fun index (word : List α) => (word.count index : ENNReal) ^ degree)
+    (fun first second hne => uniformWordAverage_mixed_power_le_product first second hne steps degree degree)
+  rw [← uniformWordAverage_sum] at h
+  apply h.trans
+  apply add_le_add le_rfl
+  simp_rw [← pow_mul]
+  calc
+    _ ≤ ∑ _index : α, stirlingPowerMoment rate (degree * 2) :=
+      Finset.sum_le_sum fun index _ => uniformWordAverage_power_le_stirling index steps (degree * 2) rate hrate
+    _ = _ := by simp only [Finset.sum_const, Finset.card_univ, nsmul_eq_mul]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/UniformPublicCoordinates.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/UniformPublicCoordinates.lean
new file mode 100644
index 000000000..eeee55b0a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/UniformPublicCoordinates.lean
@@ -0,0 +1,89 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Base.UniformTableCompletion
+namespace SphincsSecurity.Concrete.UniformPublicCoordinates
+
+open _root_.OracleComp ENNReal UniformTableCompletion
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+variable {Coordinate Value : Type} [Fintype Coordinate] [DecidableEq Coordinate]
+  [Fintype Value] [DecidableEq Value] [Nonempty Value]
+
+abbrev Public (exposed : Coordinate → Prop) := {coordinate // exposed coordinate}
+
+def restrict (exposed : Coordinate → Prop) (labels : Coordinate → Value) : Public exposed → Value :=
+  fun coordinate => labels coordinate.val
+
+noncomputable def allowed (exposed : Coordinate → Prop) (known : Public exposed → Value) : Coordinate → Finset Value :=
+  fun coordinate => if h : exposed coordinate then {known ⟨coordinate, h⟩} else Finset.univ
+
+omit [Fintype Coordinate] [DecidableEq Coordinate] [DecidableEq Value] in
+theorem allowed_nonempty (exposed : Coordinate → Prop) (known : Public exposed → Value) :
+    ∀ coordinate, (allowed exposed known coordinate).Nonempty := by
+  intro coordinate
+  unfold allowed
+  split
+  · exact Finset.singleton_nonempty _
+  · exact Finset.univ_nonempty
+
+omit [Fintype Coordinate] [DecidableEq Coordinate] [DecidableEq Value] [Nonempty Value] in
+theorem mem_allowed_iff (exposed : Coordinate → Prop) (known : Public exposed → Value)
+    (labels : Coordinate → Value) :
+    (∀ coordinate, labels coordinate ∈ allowed exposed known coordinate) ↔ restrict exposed labels = known := by
+  constructor
+  · intro h
+    funext coordinate
+    change labels coordinate.val = known coordinate
+    have hc := h coordinate.val
+    simpa only [allowed, dif_pos coordinate.property, Finset.mem_singleton] using hc
+  · intro h coordinate
+    by_cases hc : exposed coordinate
+    · simp only [allowed, dif_pos hc, Finset.mem_singleton]
+      exact congrFun h ⟨coordinate, hc⟩
+    · simp only [allowed, dif_neg hc, Finset.mem_univ]
+
+omit [DecidableEq Value] [Nonempty Value] in
+theorem allowed_card_product (exposed : Coordinate → Prop) (known : Public exposed → Value) :
+    Fintype.card (Public exposed → Value) * (∏ coordinate, (allowed exposed known coordinate).card) =
+      Fintype.card (Coordinate → Value) := by
+  have hcard : ∀ coordinate, (allowed exposed known coordinate).card =
+      if exposed coordinate then 1 else Fintype.card Value := by
+    intro coordinate
+    by_cases hc : exposed coordinate <;> simp [allowed, hc]
+  simp only [hcard, Finset.prod_ite, Finset.prod_const_one, one_mul, Finset.prod_const,
+    Fintype.card_fun, ← pow_add]
+  congr 1
+  simp only [Public, Fintype.card_subtype]
+  exact Finset.card_filter_add_card_filter_not _
+
+theorem completion_mass (exposed : Coordinate → Prop) (known : Public exposed → Value)
+    (labels : Coordinate → Value) :
+    PMF.uniformOfFintype (Public exposed → Value) known * complete (allowed exposed known) labels =
+      if restrict exposed labels = known then PMF.uniformOfFintype (Coordinate → Value) labels else 0 := by
+  simp only [complete_apply, mem_allowed_iff]
+  by_cases h : restrict exposed labels = known
+  · simp only [h, if_true, PMF.uniformOfFintype_apply]
+    rw [← ENNReal.mul_inv (by simp) (by simp), ← Nat.cast_mul, allowed_card_product]
+  · simp only [h, if_false, mul_zero]
+
+omit [Fintype Value] [Nonempty Value] in
+theorem completion_member (candidates : Coordinate → Finset Value) (labels : Coordinate → Value)
+    (hlabels : complete candidates labels ≠ 0) : ∀ coordinate, labels coordinate ∈ candidates coordinate := by
+  by_contra h
+  rw [complete_apply, if_neg h] at hlabels
+  exact hlabels rfl
+
+theorem uniform_bind_complete {Result : Type} (exposed : Coordinate → Prop)
+    (next : (Public exposed → Value) → (Coordinate → Value) → SPMF Result) :
+    ((liftM (PMF.uniformOfFintype (Coordinate → Value)) : SPMF _) >>= fun labels => next (restrict exposed labels) labels) =
+      ((liftM (PMF.uniformOfFintype (Public exposed → Value)) : SPMF _) >>= fun known =>
+        complete (allowed exposed known) >>= next known) := by
+  classical
+  apply SPMF.ext
+  intro result
+  simp only [SPMF.bind_apply_eq_tsum, SPMF.liftM_apply, ← ENNReal.tsum_mul_left,
+    ← mul_assoc, completion_mass, ite_mul, zero_mul]
+  rw [ENNReal.tsum_comm]
+  simp
+
+end SphincsSecurity.Concrete.UniformPublicCoordinates
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/UnitCertificateCoverage.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/UnitCertificateCoverage.lean
new file mode 100644
index 000000000..81bb55517
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/UnitCertificateCoverage.lean
@@ -0,0 +1,132 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CertificateJointExceptions
+import SphincsSecurity.Proof.Fts.FixedCertificateCoverage
+
+/-! ## PositivePartMomentBound -/
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp ENNReal
+
+theorem uniformWordAverage_const {α : Type} [SampleableType α] [Fintype α] [Nonempty α] [DecidableEq α]
+    (steps : Nat) (value : ENNReal) :
+    uniformWordAverage steps (fun _word : List α => value) = value := by
+  let index : α := Classical.choice inferInstance
+  rw [uniformWordAverage, expected_uniformProposalWord_count index steps (fun _ => value)]
+  exact binomialAverage_const (ENNReal.inv_le_one.mpr (by exact_mod_cast Fintype.card_pos)) steps value
+
+end SphincsSecurity.Concrete
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp ENNReal
+set_option backward.isDefEq.respectTransparency false
+
+private theorem unit_excess_le_square_with_mean (value mean : ENNReal) (hvalue : value ≠ ⊤)
+    (hmean : mean ≤ 1 / 5) :
+    (16 / 5 : ENNReal) * (value - 1) + 2 * mean * value ≤ value ^ 2 + mean ^ 2 := by
+  have hm : mean ≠ ⊤ := ne_top_of_le_ne_top (by finiteness) hmean
+  have hmr : mean.toReal ≤ 1 / 5 := by
+    have h := (ENNReal.toReal_le_toReal hm (by finiteness)).mpr hmean
+    simpa only [ENNReal.toReal_div, ENNReal.toReal_one, ENNReal.toReal_ofNat] using h
+  by_cases hsmall : value ≤ 1
+  · rw [tsub_eq_zero_of_le hsmall, mul_zero, zero_add]
+    apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp
+    simp (disch := finiteness) only [ENNReal.toReal_mul, ENNReal.toReal_pow, ENNReal.toReal_add,
+      ENNReal.toReal_ofNat]
+    nlinarith [sq_nonneg (value.toReal - mean.toReal)]
+  · have hlarge : 1 ≤ value := le_of_not_ge hsmall
+    apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp
+    simp (disch := finiteness) only [ENNReal.toReal_add, ENNReal.toReal_mul, ENNReal.toReal_pow,
+      ENNReal.toReal_sub_of_le hlarge hvalue, ENNReal.toReal_one, ENNReal.toReal_div, ENNReal.toReal_ofNat]
+    nlinarith [sq_nonneg (value.toReal - mean.toReal - 8 / 5)]
+
+theorem uniformWordAverage_fixedFull_unit_excess_le :
+    uniformWordAverage fixedProposalLength (fun word => fixedFullProposalPrice word - 1) ≤
+      (11 / 2 ^ 16 : ENNReal) := by
+  let mean := uniformWordAverage fixedProposalLength fixedFullProposalPrice
+  have hm : mean ≠ ⊤ := ne_top_of_le_ne_top (by finiteness) uniformWordAverage_fixedFull_mean_le
+  have h := uniformWordAverage_mono fixedProposalLength (fun word =>
+    unit_excess_le_square_with_mean (fixedFullProposalPrice word) mean (fixedFullProposalPrice_ne_top word)
+      uniformWordAverage_fixedFull_mean_le)
+  rw [uniformWordAverage_add, uniformWordAverage_add,
+    uniformWordAverage_mul_left, uniformWordAverage_mul_left, uniformWordAverage_const] at h
+  have hcancel : (16 / 5 : ENNReal) *
+      uniformWordAverage fixedProposalLength (fun word => fixedFullProposalPrice word - 1) ≤ 13 / 25000 := by
+    apply ENNReal.le_of_add_le_add_right (a := 2 * mean ^ 2) (by finiteness)
+    calc
+      _ = (16 / 5 : ENNReal) *
+          uniformWordAverage fixedProposalLength (fun word => fixedFullProposalPrice word - 1) +
+            2 * mean * uniformWordAverage fixedProposalLength fixedFullProposalPrice := by
+        change _ = _ + 2 * mean * mean
+        ring
+      _ ≤ uniformWordAverage fixedProposalLength (fun word => fixedFullProposalPrice word ^ 2) + mean ^ 2 := h
+      _ ≤ (mean ^ 2 + 13 / 25000) + mean ^ 2 :=
+        add_le_add uniformWordAverage_fixedFull_secondMoment_le le_rfl
+      _ = _ := by ring
+  have hunit : (5 / 16 : ENNReal) * (16 / 5) = 1 := by
+    apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp
+    norm_num [ENNReal.toReal_mul, ENNReal.toReal_div]
+  calc
+    _ = (5 / 16 : ENNReal) * ((16 / 5) *
+        uniformWordAverage fixedProposalLength (fun word => fixedFullProposalPrice word - 1)) := by
+      rw [← mul_assoc, hunit, one_mul]
+    _ ≤ (5 / 16 : ENNReal) * (13 / 25000) := mul_le_mul' le_rfl hcancel
+    _ ≤ _ := by
+      apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp
+      norm_num [ENNReal.toReal_mul, ENNReal.toReal_div, ENNReal.toReal_pow]
+
+theorem expected_fixedCertificateGame_full_unit_count_le (adversary : Adversary) (q : Nat)
+    (stopAfter : SecretKey → CertificateStopRule) (hbudget : q ≤ 2 ^ 127)
+    (hbound : HasHashQueryBound scheme adversary q) :
+    (∑' result, Pr[= result | fixedCertificateGame adversary q Finset.univ stopAfter] *
+      certificateBankCount result.1.2.2.2.bank) ≤
+        (2 ^ 128 : ENNReal)⁻¹ *
+          (∑' result, Pr[= result | fixedCertificateGame adversary q Finset.univ stopAfter] *
+            result.1.2.2.2.messageCalls) + (q : ENNReal) * (11 / 2 ^ 144 : ENNReal) := by
+  apply (expected_fixedCertificateGame_count_le_message_excess adversary q Finset.univ stopAfter
+    hbudget hbound (2 ^ 128 : ENNReal)⁻¹).trans
+  apply add_le_add le_rfl
+  apply mul_le_mul' le_rfl
+  have hscale (word : List Index) :
+      terminalCertificatePrice Finset.univ word - (2 ^ 128 : ENNReal)⁻¹ =
+        (2 ^ 128 : ENNReal)⁻¹ * (fixedFullProposalPrice word - 1) := by
+    rw [terminalCertificatePrice_full, ENNReal.mul_sub (fun _ _ => by finiteness), mul_one]
+  simp_rw [hscale]
+  rw [uniformWordAverage_mul_left]
+  calc
+    _ ≤ (2 ^ 128 : ENNReal)⁻¹ * (11 / 2 ^ 16 : ENNReal) :=
+      mul_le_mul' le_rfl uniformWordAverage_fixedFull_unit_excess_le
+    _ = _ := by
+      apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp
+      norm_num [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_div, ENNReal.toReal_pow]
+
+theorem expected_certificateCacheGame_full_unit_count_le (adversary : Adversary) (q : Nat)
+    (stopAfter : SecretKey → CertificateStopRule) (hq : q ≤ 2 ^ 127)
+    (hbound : HasHashQueryBound scheme adversary q) :
+    let law := certificateCacheGame adversary q Finset.univ
+      (fun key input state length record => proposalPrefixStop input state length record ||
+        stopAfter key input state length record) false
+    (∑' result, Pr[= result | law] * certificateBankCount result.2.2.2.1.bank) ≤
+      (2 ^ 128 : ENNReal)⁻¹ *
+        (∑' result, Pr[= result | law] * result.2.2.2.1.messageCalls) +
+          (q : ENNReal) * (11 / 2 ^ 144 : ENNReal) := by
+  dsimp only
+  have h := expected_fixedCertificateGame_full_unit_count_le adversary q stopAfter hq hbound
+  unfold fixedCertificateGame at h
+  rw [expected_certificateTerminalGame_project adversary q Finset.univ _ false fixedProposalLength
+      (fun result => certificateBankCount result.2.2.2.bank),
+    expected_certificateTerminalGame_project adversary q Finset.univ _ false fixedProposalLength
+      (fun result => (result.2.2.2.messageCalls : ENNReal))] at h
+  have hbank := expected_certificateCacheGame_project adversary q Finset.univ
+    (fun key input state length record => proposalPrefixStop input state length record ||
+      stopAfter key input state length record) false (fun result => certificateBankCount result.2.2.2.bank)
+  have hmessage := expected_certificateCacheGame_project adversary q Finset.univ
+    (fun key input state length record => proposalPrefixStop input state length record ||
+      stopAfter key input state length record) false (fun result => (result.2.2.2.messageCalls : ENNReal))
+  change (∑' result : CertificateCacheGameResult, Pr[= result | _] * certificateBankCount result.2.2.2.1.bank) = _ at hbank
+  change (∑' result : CertificateCacheGameResult, Pr[= result | _] * (result.2.2.2.1.messageCalls : ENNReal)) = _ at hmessage
+  rw [hbank, hmessage]
+  exact h
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/UnrestrictedRowSwap.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/UnrestrictedRowSwap.lean
new file mode 100644
index 000000000..e43dee61c
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/UnrestrictedRowSwap.lean
@@ -0,0 +1,125 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Base.UniformTableOverwrite
+namespace SphincsSecurity.Concrete.UnrestrictedRowSwap
+
+open ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+variable {Index Cell Answer : Type}
+
+noncomputable def swap (embed : Index → Cell) (hinj : Function.Injective embed) (kept : Index → Prop)
+    (pair : (Index → Answer) × (Cell → Answer)) : (Index → Answer) × (Cell → Answer) :=
+  (fun index => if kept index then pair.1 index else pair.2 (embed index),
+    UniformTableSplit.overwrite embed hinj
+      (fun index => if kept index then pair.2 (embed index) else pair.1 index) pair.2)
+
+theorem swap_fst_kept (embed : Index → Cell) (hinj : Function.Injective embed) (kept : Index → Prop)
+    (pair : (Index → Answer) × (Cell → Answer)) (index : Index) (hkept : kept index) :
+    (swap embed hinj kept pair).1 index = pair.1 index := if_pos hkept
+
+theorem swap_snd_embed (embed : Index → Cell) (hinj : Function.Injective embed) (kept : Index → Prop)
+    (pair : (Index → Answer) × (Cell → Answer)) (index : Index) :
+    (swap embed hinj kept pair).2 (embed index) = if kept index then pair.2 (embed index) else pair.1 index :=
+  UniformTableSplit.overwrite_embed embed hinj _ _ index
+
+theorem swap_snd_outside (embed : Index → Cell) (hinj : Function.Injective embed) (kept : Index → Prop)
+    (pair : (Index → Answer) × (Cell → Answer)) (cell : Cell) (hout : cell ∉ Set.range embed) :
+    (swap embed hinj kept pair).2 cell = pair.2 cell :=
+  UniformTableSplit.overwrite_outside embed hinj _ _ cell hout
+
+theorem swap_involutive (embed : Index → Cell) (hinj : Function.Injective embed) (kept : Index → Prop) :
+    Function.Involutive (swap (Answer := Answer) embed hinj kept) := by
+  intro pair
+  apply Prod.ext
+  · funext index
+    change (if kept index then (swap embed hinj kept pair).1 index else (swap embed hinj kept pair).2 (embed index)) = _
+    rw [swap_snd_embed]
+    by_cases hk : kept index <;> simp only [swap, hk, if_true, if_false]
+  · funext cell
+    by_cases hin : cell ∈ Set.range embed
+    · obtain ⟨index, rfl⟩ := hin
+      rw [swap_snd_embed, swap_snd_embed]
+      by_cases hk : kept index <;> simp only [swap, hk, if_true, if_false]
+    · rw [swap_snd_outside embed hinj kept _ cell hin, swap_snd_outside embed hinj kept _ cell hin]
+
+noncomputable def prefixOverwrite (embed : Index → Cell) (hinj : Function.Injective embed) (kept : Index → Prop)
+    (rows : Index → Answer) (seed : Cell → Answer) : Cell → Answer :=
+  UniformTableSplit.overwrite embed hinj (fun index => if kept index then rows index else seed (embed index)) seed
+
+theorem prefixOverwrite_embed (embed : Index → Cell) (hinj : Function.Injective embed) (kept : Index → Prop)
+    (rows : Index → Answer) (seed : Cell → Answer) (index : Index) :
+    prefixOverwrite embed hinj kept rows seed (embed index) = if kept index then rows index else seed (embed index) :=
+  UniformTableSplit.overwrite_embed embed hinj _ _ index
+
+theorem prefixOverwrite_outside (embed : Index → Cell) (hinj : Function.Injective embed) (kept : Index → Prop)
+    (rows : Index → Answer) (seed : Cell → Answer) (cell : Cell) (hout : cell ∉ Set.range embed) :
+    prefixOverwrite embed hinj kept rows seed cell = seed cell :=
+  UniformTableSplit.overwrite_outside embed hinj _ _ cell hout
+
+theorem prefixOverwrite_swap (embed : Index → Cell) (hinj : Function.Injective embed) (kept : Index → Prop)
+    (pair : (Index → Answer) × (Cell → Answer)) :
+    prefixOverwrite embed hinj kept (swap embed hinj kept pair).1 (swap embed hinj kept pair).2 =
+      UniformTableSplit.overwrite embed hinj pair.1 pair.2 := by
+  funext cell
+  by_cases hin : cell ∈ Set.range embed
+  · obtain ⟨index, rfl⟩ := hin
+    simp only [prefixOverwrite, UniformTableSplit.overwrite_embed, swap_snd_embed]
+    by_cases hk : kept index <;> simp only [swap, hk, if_true, if_false]
+  · rw [prefixOverwrite, UniformTableSplit.overwrite_outside embed hinj _ _ cell hin,
+      swap_snd_outside embed hinj kept _ cell hin, UniformTableSplit.overwrite_outside embed hinj _ _ cell hin]
+
+noncomputable def pairLaw {Left Right : Type} (left : PMF Left) (right : PMF Right) : PMF (Left × Right) :=
+  left.bind (fun a => right.map (fun b => (a, b)))
+
+theorem pairLaw_apply {Left Right : Type} (left : PMF Left) (right : PMF Right) (pair : Left × Right) :
+    pairLaw left right pair = left pair.1 * right pair.2 := by
+  letI : DecidableEq Left := Classical.decEq Left
+  letI : DecidableEq Right := Classical.decEq Right
+  rcases pair with ⟨a, b⟩
+  have hmap (other : Left) : right.map (fun b => (other, b)) (a, b) = if other = a then right b else 0 := by
+    rw [PMF.map_apply]
+    by_cases heq : other = a
+    · subst other
+      simp only [Prod.mk.injEq, true_and, ite_true]
+      simp
+    · simp only [Prod.mk.injEq, heq, Ne.symm heq, false_and, if_false, tsum_zero]
+  simp only [pairLaw, PMF.bind_apply, hmap, mul_ite, mul_zero]
+  simp
+
+theorem map_involutive {Value : Type} (law : PMF Value) (f : Value → Value)
+    (hinv : Function.Involutive f) (hmass : ∀ value, law (f value) = law value) : law.map f = law := by
+  letI : DecidableEq Value := Classical.decEq Value
+  apply PMF.ext
+  intro value
+  rw [PMF.map_apply, tsum_eq_single (f value)]
+  · rw [if_pos (hinv value).symm, hmass]
+  · intro other hne
+    exact if_neg (fun h => hne ((hinv other).symm.trans (congrArg f h.symm)))
+
+variable [Fintype Cell] [DecidableEq Cell] [Fintype Answer] [Nonempty Answer]
+
+theorem pairLaw_swap (embed : Index → Cell) (hinj : Function.Injective embed) (kept : Index → Prop)
+    (law : PMF (Index → Answer))
+    (hkept : ∀ left right, (∀ index, kept index → left index = right index) → law left = law right) :
+    (pairLaw law (PMF.uniformOfFintype (Cell → Answer))).map (swap embed hinj kept) =
+      pairLaw law (PMF.uniformOfFintype (Cell → Answer)) := by
+  apply map_involutive _ _ (swap_involutive embed hinj kept)
+  intro pair
+  simp only [pairLaw_apply, PMF.uniformOfFintype_apply]
+  rw [hkept _ pair.1 (fun index hk => swap_fst_kept embed hinj kept pair index hk)]
+
+theorem overwrite_eq_prefix (embed : Index → Cell) (hinj : Function.Injective embed) (kept : Index → Prop)
+    (law : PMF (Index → Answer))
+    (hkept : ∀ left right, (∀ index, kept index → left index = right index) → law left = law right) :
+    law.bind (fun rows => (PMF.uniformOfFintype (Cell → Answer)).map
+      (fun seed => ((fun index : {index // kept index} => rows index.val), UniformTableSplit.overwrite embed hinj rows seed))) =
+    law.bind (fun rows => (PMF.uniformOfFintype (Cell → Answer)).map
+      (fun seed => ((fun index : {index // kept index} => rows index.val), prefixOverwrite embed hinj kept rows seed))) := by
+  have h := congrArg (fun distribution : PMF ((Index → Answer) × (Cell → Answer)) => distribution.map
+    (fun pair => ((fun index : {index // kept index} => pair.1 index.val), prefixOverwrite embed hinj kept pair.1 pair.2)))
+    (pairLaw_swap embed hinj kept law hkept)
+  simpa only [PMF.map_comp, Function.comp_def, prefixOverwrite_swap, swap_fst_kept _ _ _ _ _ (Subtype.property _),
+    pairLaw, PMF.map_bind] using h
+
+end SphincsSecurity.Concrete.UnrestrictedRowSwap
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/UpperDigestSelection.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/UpperDigestSelection.lean
new file mode 100644
index 000000000..506067ed5
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/UpperDigestSelection.lean
@@ -0,0 +1,68 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FreshDigestHazard
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] signAttempt signDigestAttemptPrefix signDigestLoop
+
+theorem probEvent_signDigestAttemptPrefix_fresh_le_admissibility
+    (key : SecretKey) (message : Message) (reference cache : QueryCache HashSpec)
+    (hinvariant : OnlyRejectedNewMessageEntries reference cache key message) :
+    Pr[FreshDigestAttempt reference key message | signDigestAttemptPrefix key message cache] ≤
+      ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ := by
+  rw [signDigestAttemptPrefix]
+  apply probEvent_bind_le_of_forall_le
+  intro randomness _
+  rw [show (fun result => pure (randomness, result)) = pure ∘ fun result => (randomness, result) from rfl,
+    probEvent_bind_pure_comp]
+  change Pr[fun result => reference (tweakableHashInput key.parameter .message
+      (messageDigestPayload key.root message randomness)) = none ∧ result.1 ≠ none |
+      (simulateQ (randomOracle : QueryImpl HashSpec _) (signAttempt key message randomness)).run cache] ≤ _
+  by_cases href : reference (tweakableHashInput key.parameter .message
+      (messageDigestPayload key.root message randomness)) = none
+  · simp only [href, true_and]
+    cases hc : cache (tweakableHashInput key.parameter .message
+        (messageDigestPayload key.root message randomness)) with
+    | none => exact (probEvent_signAttempt_fresh_success_eq key message randomness cache hc).le
+    | some output =>
+        apply le_of_eq_of_le (probEvent_eq_zero ?_) zero_le
+        intro result hr hsuccess
+        have hle : cache ≤ result.2 :=
+          simulateQ_romImpl_cache_le (liftM (signAttempt key message randomness :
+            OracleComp HashSpec (Option (Index × (IndexGroup → FtsLeaf))))) cache result (by
+              rw [simulateQ_romImpl_liftM]
+              exact hr)
+        exact hsuccess ((signAttempt_result_of_cached key message randomness cache result.2 result.1 output
+          (hle hc) hr).trans (hinvariant randomness output href hc))
+  · apply le_of_eq_of_le (probEvent_eq_zero ?_) zero_le
+    intro result _ hevent
+    exact href hevent.1
+
+theorem probEvent_signDigestLoop_fresh_le_attempts_mul_admissibility
+    (attempts : Nat) (key : SecretKey) (message : Message) (reference cache : QueryCache HashSpec)
+    (hinvariant : OnlyRejectedNewMessageEntries reference cache key message) :
+    Pr[fun result => freshSelectedLoopView? reference key message result ≠ none |
+      (simulateQ romImpl (signDigestLoop attempts key message)).run cache] ≤
+      digestAttemptExpectation attempts key message cache * ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ := by
+  induction attempts generalizing cache with
+  | zero => simp [signDigestLoop, freshSelectedLoopView?, digestAttemptExpectation]
+  | succ attempts ih =>
+      rw [probEvent_signDigestLoop_fresh_recurrence, digestAttemptExpectation, add_mul, one_mul,
+        ← ENNReal.tsum_mul_right]
+      apply add_le_add (probEvent_signDigestAttemptPrefix_fresh_le_admissibility key message reference cache hinvariant)
+      apply ENNReal.tsum_le_tsum
+      intro result
+      by_cases hr : result ∈ support (signDigestAttemptPrefix key message cache)
+      · by_cases hnone : result.2.1 = none
+        · rw [if_pos hnone, if_pos hnone, mul_assoc]
+          apply mul_le_mul' le_rfl
+          apply ih
+          apply onlyRejectedNewMessageEntries_of_failed_attempt reference cache result.2.2 key message result.1 hinvariant
+          have heq : result.2 = (none, result.2.2) := Prod.ext hnone rfl
+          rw [← heq]
+          exact signDigestAttemptPrefix_support_attempt key message cache result hr
+        · simp only [if_neg hnone, mul_zero, zero_mul, le_refl]
+      · simp only [probOutput_eq_zero_of_not_mem_support hr, zero_mul, le_refl]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/ValidInterleavedCover.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/ValidInterleavedCover.lean
new file mode 100644
index 000000000..1314da940
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/ValidInterleavedCover.lean
@@ -0,0 +1,12 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.InterleavedCoverStep
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (messageAnswers)
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+def ValidSigningStep (log : QueryLog SigningSpec) : (OracleWorld + SigningSpec).Domain → Prop
+  | .inl _ => log.length ≤ signatureLimit
+  | .inr _ => log.length < signatureLimit
diff --git a/formal/sphincs/SphincsSecurity/Proof/Fts/WeightedTargetGroups.lean b/formal/sphincs/SphincsSecurity/Proof/Fts/WeightedTargetGroups.lean
new file mode 100644
index 000000000..f9b757643
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Fts/WeightedTargetGroups.lean
@@ -0,0 +1,51 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.SourceGroupExpectation
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem expected_weighted_targetGroups {α : Type} [Fintype α] [DecidableEq α] (groups : α → Finset FtsTree)
+    (hne : ∀ slot, (groups slot).Nonempty) (hdisjoint : Pairwise (fun i j => Disjoint (groups i) (groups j)))
+    (weight : α → FewTimeView → ENNReal) :
+    (∑' target, Pr[= target | ($ᵗ FewTimeView : ProbComp FewTimeView)] *
+      ∏ slot : α, ∑ source : FewTimeView, weight slot source * normalizedSourceSubsetMatch target source (groups slot)) =
+        (Fintype.card Index : ENNReal)⁻¹ *
+          ∑ index : Index, ∏ slot : α, ∑ source : FewTimeView, if source.1 = index then weight slot source else 0 := by
+  classical
+  have hproduct (target : FewTimeView) :
+      (∏ slot : α, ∑ source : FewTimeView, weight slot source * normalizedSourceSubsetMatch target source (groups slot)) =
+        ∑ sources : α → FewTimeView, (∏ slot : α, weight slot (sources slot)) *
+          ∏ slot : α, normalizedSourceSubsetMatch target (sources slot) (groups slot) := by
+    rw [Fintype.prod_sum]
+    simp only [Finset.prod_mul_distrib]
+  have hindex (index : Index) :
+      (∏ slot : α, ∑ source : FewTimeView, if source.1 = index then weight slot source else 0) =
+        ∑ sources : α → FewTimeView, ∏ slot : α, if (sources slot).1 = index then weight slot (sources slot) else 0 :=
+    Fintype.prod_sum _
+  have hexpect (sources : α → FewTimeView) :
+      (∑ target : FewTimeView, Pr[= target | ($ᵗ FewTimeView : ProbComp FewTimeView)] *
+        ((∏ slot : α, weight slot (sources slot)) * ∏ slot : α, normalizedSourceSubsetMatch target (sources slot) (groups slot))) =
+        (∏ slot : α, weight slot (sources slot)) * ((Fintype.card Index : ENNReal)⁻¹ *
+          ∑ index : Index, ∏ slot : α, if (sources slot).1 = index then (1 : ENNReal) else 0) := by
+    simp only [mul_left_comm (Pr[= _ | ($ᵗ FewTimeView : ProbComp FewTimeView)]), ← Finset.mul_sum]
+    apply congrArg (fun value : ENNReal => (∏ slot : α, weight slot (sources slot)) * value)
+    simpa only [tsum_fintype] using expected_normalized_sourceGroupMatches groups hne hdisjoint sources
+  simp only [tsum_fintype, hproduct, hindex, Finset.mul_sum]
+  rw [Finset.sum_comm]
+  simp only [hexpect, Finset.mul_sum]
+  rw [Finset.sum_comm]
+  apply Finset.sum_congr rfl
+  intro index _
+  apply Finset.sum_congr rfl
+  intro sources _
+  rw [show (∏ slot : α, if (sources slot).1 = index then weight slot (sources slot) else 0) =
+      (∏ slot : α, weight slot (sources slot)) * ∏ slot : α, if (sources slot).1 = index then (1 : ENNReal) else 0 by
+    rw [← Finset.prod_mul_distrib]
+    apply Finset.prod_congr rfl
+    intro slot _
+    split_ifs <;> simp only [mul_one, mul_zero]]
+  ring
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalGraph.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalGraph.lean
new file mode 100644
index 000000000..d7e9fa536
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalGraph.lean
@@ -0,0 +1,142 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.FiniteGraphSampling
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec OracleComp.DeferredSampling
+set_option backward.isDefEq.respectTransparency false
+
+abbrev CanonicalGraphLabels := Position → HashOutput
+
+def canonicalGraphSlots
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (labels : CanonicalGraphLabels) : Position → List Digest
+  | .chain lay tree leaf chain step =>
+      if step.val = 0 then [otsSecret lay tree leaf chain]
+      else (Position.chain lay tree leaf chain step).children.map (fun child => truncateHash (labels child))
+  | .ftsLeaf index tree leaf => [ftsSecret index tree leaf]
+  | position => position.children.map (fun child => truncateHash (labels child))
+
+def canonicalGraphInput (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (position : Position) (labels : CanonicalGraphLabels) : HashInput :=
+  tweakableHashInput parameter position.domain
+    ((canonicalGraphSlots otsSecret ftsSecret labels position).flatMap digestBytes)
+
+variable (parameter : PublicParameter)
+  (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+  (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+
+theorem canonicalGraphInput_separated :
+    FiniteGraphSampling.Separated (canonicalGraphInput parameter otsSecret ftsSecret) := by
+  intro left right hne before after heq
+  exact hne (Position.domain_injective
+    (tweakableHashInput_injective parameter left.domain_inRange right.domain_inRange heq).1)
+
+theorem canonicalGraphInput_congr (position : Position) (left right : CanonicalGraphLabels)
+    (hchildren : ∀ child ∈ position.children, truncateHash (left child) = truncateHash (right child)) :
+    canonicalGraphInput parameter otsSecret ftsSecret position left =
+      canonicalGraphInput parameter otsSecret ftsSecret position right := by
+  have hmap := List.map_congr_left hchildren
+  apply congrArg (fun values : List Digest =>
+    tweakableHashInput parameter position.domain (values.flatMap digestBytes))
+  cases position <;> simp only [canonicalGraphSlots] <;>
+    first | rfl | exact hmap | (split_ifs <;> first | rfl | exact hmap)
+
+theorem canonicalGraphInput_eq_honest (f : QueryImpl HashSpec Id) (position : Position)
+    (hvalid : position.Valid) (labels : CanonicalGraphLabels)
+    (hchildren : ∀ child ∈ position.children,
+      truncateHash (labels child) = honestValue f parameter otsSecret ftsSecret child) :
+    canonicalGraphInput parameter otsSecret ftsSecret position labels =
+      honestInput f parameter otsSecret ftsSecret position := by
+  rw [honestInput, honestPayload_eq_slots f parameter otsSecret ftsSecret hvalid]
+  have hmap := List.map_congr_left hchildren
+  apply congrArg (fun values : List Digest =>
+    tweakableHashInput parameter position.domain (values.flatMap digestBytes))
+  cases position <;> simp only [canonicalGraphSlots, slots, childValues] <;>
+    first | rfl | exact hmap | (split_ifs <;> first | rfl | exact hmap)
+
+def readCanonicalGraph (f : QueryImpl HashSpec Id) (positions : List Position)
+    (labels : CanonicalGraphLabels) : CanonicalGraphLabels :=
+  FiniteGraphSampling.read (canonicalGraphInput parameter otsSecret ftsSecret)
+    (fun position output values => Function.update values position output) f positions labels
+
+theorem readCanonicalGraph_preserves (f : QueryImpl HashSpec Id) (positions : List Position)
+    (labels : CanonicalGraphLabels) (position : Position) (hposition : position ∉ positions) :
+    readCanonicalGraph parameter otsSecret ftsSecret f positions labels position = labels position := by
+  induction positions generalizing labels with
+  | nil => rfl
+  | cons first rest ih =>
+      have hne : position ≠ first := fun h => hposition (by simp [h])
+      have hrest : position ∉ rest := fun h => hposition (List.mem_cons_of_mem _ h)
+      change readCanonicalGraph parameter otsSecret ftsSecret f rest
+        (Function.update labels first (f (canonicalGraphInput parameter otsSecret ftsSecret first labels))) position = _
+      rw [ih _ hrest, Function.update_of_ne hne]
+
+theorem readCanonicalGraph_consistent (f : QueryImpl HashSpec Id) (positions : List Position)
+    (hnodup : positions.Nodup)
+    (hsorted : positions.Pairwise (fun left right => left.depth ≤ right.depth))
+    (labels : CanonicalGraphLabels) :
+    ∀ position ∈ positions,
+      readCanonicalGraph parameter otsSecret ftsSecret f positions labels position =
+        f (canonicalGraphInput parameter otsSecret ftsSecret position
+          (readCanonicalGraph parameter otsSecret ftsSecret f positions labels)) := by
+  induction positions generalizing labels with
+  | nil => simp
+  | cons first rest ih =>
+      obtain ⟨hfirst, hrest⟩ := List.nodup_cons.mp hnodup
+      obtain ⟨hdepth, hsorted⟩ := List.pairwise_cons.mp hsorted
+      intro position hposition
+      rcases List.mem_cons.mp hposition with hposition | hposition
+      · subst position
+        have hinput : canonicalGraphInput parameter otsSecret ftsSecret first
+            (readCanonicalGraph parameter otsSecret ftsSecret f (first :: rest) labels) =
+              canonicalGraphInput parameter otsSecret ftsSecret first labels := by
+          apply canonicalGraphInput_congr
+          intro child hchild
+          apply congrArg truncateHash
+          apply readCanonicalGraph_preserves
+          intro hmem
+          have hlt := Position.depth_lt_of_mem_children hchild
+          rcases List.mem_cons.mp hmem with heq | hmem
+          · subst child
+            omega
+          · have := hdepth child hmem
+            omega
+        rw [hinput]
+        change readCanonicalGraph parameter otsSecret ftsSecret f rest
+          (Function.update labels first (f (canonicalGraphInput parameter otsSecret ftsSecret first labels))) first = _
+        rw [readCanonicalGraph_preserves _ _ _ _ _ _ _ hfirst, Function.update_self]
+      · exact ih hrest hsorted _ position hposition
+
+noncomputable def canonicalGraphOrder : List Position :=
+  (Finset.univ : Finset Position).toList.mergeSort (fun left right => decide (left.depth ≤ right.depth))
+
+theorem canonicalGraphOrder_nodup : canonicalGraphOrder.Nodup := by
+  exact (List.mergeSort_perm _ _).nodup_iff.mpr (Finset.nodup_toList _)
+
+theorem mem_canonicalGraphOrder (position : Position) : position ∈ canonicalGraphOrder := by
+  rw [canonicalGraphOrder, List.mem_mergeSort]
+  simp
+
+theorem canonicalGraphOrder_sorted :
+    canonicalGraphOrder.Pairwise (fun left right => left.depth ≤ right.depth) := by
+  have h := List.pairwise_mergeSort
+    (le := fun left right : Position => decide (left.depth ≤ right.depth))
+    (by intro a b c hab hbc; simp only [decide_eq_true_eq] at *; omega)
+    (by intro a b; simp [Bool.or_eq_true]; omega)
+    (Finset.univ : Finset Position).toList
+  simpa only [canonicalGraphOrder, decide_eq_true_eq] using h
+
+noncomputable def canonicalGraphLabels (f : QueryImpl HashSpec Id) : CanonicalGraphLabels :=
+  readCanonicalGraph parameter otsSecret ftsSecret f canonicalGraphOrder (fun _ => 0)
+
+theorem canonicalGraphLabels_consistent (f : QueryImpl HashSpec Id) (position : Position) :
+    canonicalGraphLabels parameter otsSecret ftsSecret f position =
+      f (canonicalGraphInput parameter otsSecret ftsSecret position
+        (canonicalGraphLabels parameter otsSecret ftsSecret f)) :=
+  readCanonicalGraph_consistent parameter otsSecret ftsSecret f canonicalGraphOrder
+    canonicalGraphOrder_nodup canonicalGraphOrder_sorted _ position (mem_canonicalGraphOrder position)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalGraphGame.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalGraphGame.lean
new file mode 100644
index 000000000..87c611147
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalGraphGame.lean
@@ -0,0 +1,124 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.CanonicalGraphHonest
+import SphincsSecurity.Proof.Hypertree.CanonicalGraphSampling
+import SphincsSecurity.Proof.Ots.EncodingInputs
+import SphincsSecurity.Proof.Hypertree.FrontierRandomOracle
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec OracleComp.DeferredSampling
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalGraphInputs canonicalPayloadInputs canonicalEncodingInputs
+
+noncomputable def graphFrontierGameRest (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (labels : CanonicalGraphLabels)
+    (f : QueryImpl HashSpec Id) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    ProbComp (Bool × SigningBoundaryTrace) := do
+  let key : SecretKey := ⟨parameter, canonicalGraphRoot labels, otsSecret, ftsSecret⟩
+  let words := canonicalReferenceWords key f dummy
+  frontierGame parameter f ftsSecret words (canonicalGraphFrontier otsSecret labels words) adversary
+
+theorem graphFrontierGameRest_canonical (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (f : QueryImpl HashSpec Id) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    graphFrontierGameRest parameter otsSecret ftsSecret
+      (canonicalGraphLabels parameter otsSecret ftsSecret f) f dummy adversary =
+        fixedBoundaryRun parameter f (gameAfterSecrets adversary parameter otsSecret ftsSecret) := by
+  rw [graphFrontierGameRest, canonicalGraphLabels_root,
+    canonicalGraphLabels_frontier parameter otsSecret ftsSecret f _
+      (evalWithAnswerFn f (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))),
+    fixedBoundaryRun_gameAfterSecrets_canonical adversary parameter otsSecret ftsSecret f dummy]
+
+noncomputable def fixedGraphGame (f : QueryImpl HashSpec Id) (dummy : OtsReferenceWords)
+    (adversary : Adversary) : ProbComp (Bool × SigningBoundaryTrace) := do
+  let parameter ← sampleParameter
+  let otsSecret ← sampleOtsSecrets
+  let ftsSecret ← sampleFtsSecrets
+  graphFrontierGameRest parameter otsSecret ftsSecret
+    (canonicalGraphLabels parameter otsSecret ftsSecret f) f dummy adversary
+
+theorem fixedGraphGame_eq_frontier (f : QueryImpl HashSpec Id) (dummy : OtsReferenceWords)
+    (adversary : Adversary) : fixedGraphGame f dummy adversary = fixedFrontierGame f dummy adversary := by
+  rw [← simulateQ_boundaryGameCore_frontier f dummy adversary, boundaryGameCore, fixedGraphGame]
+  simp only [simulateQ_bind, simulateQ_fixedHashWorld_lift_prob]
+  apply bind_congr
+  intro parameter
+  apply bind_congr
+  intro otsSecret
+  apply bind_congr
+  intro ftsSecret
+  rw [graphFrontierGameRest_canonical, fixedBoundaryRun_eq_boundaryComputation]
+
+noncomputable def canonicalGraphOracleGame (inputs : Finset HashInput)
+    (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) : ProbComp (Bool × SigningBoundaryTrace) := do
+  let parameter ← sampleParameter
+  let otsSecret ← sampleOtsSecrets
+  let ftsSecret ← sampleFtsSecrets
+  let graph ← plantCanonicalGraph parameter otsSecret ftsSecret inputs (hgraph parameter)
+  graphFrontierGameRest parameter otsSecret ftsSecret graph.1
+    (finiteHashAnswer ∅ inputs graph.2) dummy adversary
+
+theorem evalDist_frontier_eq_canonicalGraph (inputs : Finset HashInput)
+    (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    𝒟[frontierOracleGame inputs dummy adversary] =
+      𝒟[canonicalGraphOracleGame inputs hgraph dummy adversary] := by
+  rw [frontierOracleGame, canonicalGraphOracleGame]
+  simp_rw [← fixedGraphGame_eq_frontier]
+  simp only [fixedGraphGame]
+  rw [evalDist_bind_comm]
+  apply evalDist_bind_congr_left
+  intro parameter
+  rw [evalDist_bind_comm]
+  apply evalDist_bind_congr_left
+  intro otsSecret
+  rw [evalDist_bind_comm]
+  apply evalDist_bind_congr_left
+  intro ftsSecret
+  exact evalDist_canonicalGraph_bind_eq_plant parameter otsSecret ftsSecret inputs (hgraph parameter)
+    (fun labels table => graphFrontierGameRest parameter otsSecret ftsSecret labels
+      (finiteHashAnswer ∅ inputs table) dummy adversary)
+
+theorem evalDist_boundaryGameCore_canonicalGraph (inputs : Finset HashInput)
+    (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary)
+    (hinputs : hashInputs (boundaryGameCore adversary) ⊆ inputs) :
+    𝒟[(simulateQ romImpl (boundaryGameCore adversary)).run' ∅] =
+      𝒟[canonicalGraphOracleGame inputs hgraph dummy adversary] := by
+  exact (evalDist_boundaryGameCore_frontier inputs dummy adversary hinputs).trans
+    (evalDist_frontier_eq_canonicalGraph inputs hgraph dummy adversary)
+
+noncomputable def canonicalGraphGameInputs (adversary : Adversary) : Finset HashInput :=
+  (hashInputs (boundaryGameCore adversary) ∪ Finset.univ.biUnion canonicalGraphInputs) ∪
+    Finset.univ.biUnion canonicalEncodingInputs
+
+attribute [local irreducible] canonicalGraphGameInputs
+
+theorem canonicalGraphInputs_subset_gameInputs (adversary : Adversary) (parameter : PublicParameter) :
+    canonicalGraphInputs parameter ⊆ canonicalGraphGameInputs adversary := by
+  intro input hinput
+  rw [canonicalGraphGameInputs, Finset.mem_union]
+  apply Or.inl
+  rw [Finset.mem_union]
+  apply Or.inr
+  rw [Finset.mem_biUnion]
+  simp only [Finset.mem_univ, true_and]
+  exact ⟨parameter, hinput⟩
+
+theorem hashInputs_subset_canonicalGraphGameInputs (adversary : Adversary) :
+    hashInputs (boundaryGameCore adversary) ⊆ canonicalGraphGameInputs adversary := by
+  rw [canonicalGraphGameInputs]
+  exact Finset.Subset.trans Finset.subset_union_left Finset.subset_union_left
+
+theorem canonicalEncodingInputs_subset_gameInputs (adversary : Adversary) (parameter : PublicParameter) :
+    canonicalEncodingInputs parameter ⊆ canonicalGraphGameInputs adversary := by
+  intro input hinput
+  rw [canonicalGraphGameInputs, Finset.mem_union]
+  apply Or.inr
+  rw [Finset.mem_biUnion]
+  simp only [Finset.mem_univ, true_and]
+  exact ⟨parameter, hinput⟩
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalGraphHonest.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalGraphHonest.lean
new file mode 100644
index 000000000..663a3b0d4
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalGraphHonest.lean
@@ -0,0 +1,143 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.CanonicalGraph
+import SphincsSecurity.Proof.Hypertree.CanonicalSigningFrontier
+namespace SphincsSecurity
+
+namespace Position
+
+def TreeBound : Position → Prop
+  | .node _ _ level index => 2 ^ (level.val + 1) * (index.val + 1) ≤ 2 ^ maxLayerHeight
+  | .ftsNode _ _ level index => 2 ^ (level.val + 1) * (index.val + 1) ≤ 2 ^ ftsTreeHeight
+  | _ => True
+
+theorem TreeBound.valid (position : Position) (h : position.TreeBound) : position.Valid := by
+  cases position with
+  | node lay tree level index =>
+      have hpow : 0 < (2 : Nat) ^ level.val := pow_pos (by decide) _
+      have hmul := Nat.mul_le_mul_right (index.val + 1) (show 2 ≤ 2 ^ (level.val + 1) by
+        rw [pow_succ]; omega)
+      change 2 ^ (level.val + 1) * (index.val + 1) ≤ 2 ^ maxLayerHeight at h
+      change 2 * index.val + 1 < 2 ^ maxLayerHeight
+      omega
+  | ftsNode index tree level node =>
+      have hpow : 0 < (2 : Nat) ^ level.val := pow_pos (by decide) _
+      have hmul := Nat.mul_le_mul_right (node.val + 1) (show 2 ≤ 2 ^ (level.val + 1) by
+        rw [pow_succ]; omega)
+      change 2 ^ (level.val + 1) * (node.val + 1) ≤ 2 ^ ftsTreeHeight at h
+      change 2 * node.val + 1 < 2 ^ ftsTreeHeight
+      omega
+  | chain | leaf | ftsLeaf | ftsRoots => trivial
+
+private theorem treeBound_children_arithmetic (height level index : Nat)
+    (h : 2 ^ (level + 1) * (index + 1) ≤ 2 ^ height) :
+    2 ^ level * (2 * index + 1) ≤ 2 ^ height ∧
+      2 ^ level * (2 * index + 1 + 1) ≤ 2 ^ height := by
+  rw [pow_succ] at h
+  constructor <;> nlinarith [Nat.zero_le (2 ^ level)]
+
+theorem TreeBound.child {position child : Position} (h : position.TreeBound)
+    (hchild : child ∈ position.children) : child.TreeBound := by
+  cases position with
+  | chain lay tree leaf chain step =>
+      simp only [children] at hchild
+      split_ifs at hchild with hstep
+      · rw [List.mem_singleton] at hchild
+        subst child
+        trivial
+      · simp at hchild
+  | leaf lay tree leaf =>
+      simp only [children, List.mem_ofFn] at hchild
+      obtain ⟨chain, rfl⟩ := hchild
+      trivial
+  | node lay tree level index =>
+      have hvalid : 2 * index.val + 1 < 2 ^ maxLayerHeight := TreeBound.valid _ h
+      rw [children, dif_pos hvalid] at hchild
+      split_ifs at hchild with hlevel
+      · have bounds := treeBound_children_arithmetic maxLayerHeight level.val index.val h
+        rcases List.mem_pair.mp hchild with hchild | hchild <;> subst child <;>
+          simp only [TreeBound, show level.val - 1 + 1 = level.val by omega] <;>
+          first | exact bounds.1 | exact bounds.2
+      · rcases List.mem_pair.mp hchild with hchild | hchild <;> subst child <;> trivial
+  | ftsLeaf => simp [children] at hchild
+  | ftsNode index tree level node =>
+      have hvalid : 2 * node.val + 1 < 2 ^ ftsTreeHeight := TreeBound.valid _ h
+      rw [children, dif_pos hvalid] at hchild
+      split_ifs at hchild with hlevel
+      · have bounds := treeBound_children_arithmetic ftsTreeHeight level.val node.val h
+        rcases List.mem_pair.mp hchild with hchild | hchild <;> subst child <;>
+          simp only [TreeBound, show level.val - 1 + 1 = level.val by omega] <;>
+          first | exact bounds.1 | exact bounds.2
+      · rcases List.mem_pair.mp hchild with hchild | hchild <;> subst child <;> trivial
+  | ftsRoots index =>
+      simp only [children, List.mem_ofFn] at hchild
+      obtain ⟨tree, rfl⟩ := hchild
+      norm_num [TreeBound, ftsTreeHeight]
+
+end Position
+
+namespace Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable (parameter : PublicParameter)
+  (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+  (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+
+theorem canonicalGraphLabels_eq_honest (f : QueryImpl HashSpec Id)
+    (position : Position) (hbound : position.TreeBound) :
+    canonicalGraphLabels parameter otsSecret ftsSecret f position =
+      f (honestInput f parameter otsSecret ftsSecret position) := by
+  induction hdepth : position.depth using Nat.strong_induction_on generalizing position with
+  | h depth ih =>
+      rw [canonicalGraphLabels_consistent]
+      apply congrArg f
+      apply canonicalGraphInput_eq_honest parameter otsSecret ftsSecret f position (hbound.valid position)
+      intro child hchild
+      have hlt : child.depth < depth := by
+        rw [← hdepth]
+        exact Position.depth_lt_of_mem_children hchild
+      rw [ih child.depth hlt child (hbound.child hchild) rfl]
+      rfl
+
+theorem canonicalGraphLabels_chain (f : QueryImpl HashSpec Id) (lay : Layer) (tree : TreeIndex)
+    (leaf : LeafIndex) (chain : ChainIndex) (step : ChainStep) :
+    truncateHash (canonicalGraphLabels parameter otsSecret ftsSecret f (.chain lay tree leaf chain step)) =
+      honestChain f parameter lay tree leaf chain (otsSecret lay tree leaf chain) (step.val + 1) := by
+  rw [canonicalGraphLabels_eq_honest parameter otsSecret ftsSecret f _ (by trivial)]
+  exact honestValue_chain f parameter otsSecret ftsSecret lay tree leaf chain step
+
+def canonicalGraphRoot (labels : CanonicalGraphLabels) : Digest :=
+  truncateHash (labels (.node topLayer rootTree ⟨maxLayerHeight - 1, by decide⟩ ⟨0, by positivity⟩))
+
+theorem canonicalGraphLabels_root (f : QueryImpl HashSpec Id) :
+    canonicalGraphRoot (canonicalGraphLabels parameter otsSecret ftsSecret f) =
+      evalWithAnswerFn f (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree)) := by
+  rw [canonicalGraphRoot, canonicalGraphLabels_eq_honest parameter otsSecret ftsSecret f _
+    (by norm_num [Position.TreeBound, maxLayerHeight])]
+  change honestValue f parameter otsSecret ftsSecret _ = _
+  rw [honestValue_node]
+  rfl
+
+def canonicalGraphFrontier (labels : CanonicalGraphLabels) (words : OtsReferenceWords) : OtsFrontierValues :=
+  fun lay tree leaf chain =>
+    if h : (words lay tree leaf chain).val = 0 then otsSecret lay tree leaf chain
+    else truncateHash (labels (.chain lay tree leaf chain
+      ⟨(words lay tree leaf chain).val - 1, by have := (words lay tree leaf chain).isLt; omega⟩))
+
+theorem canonicalGraphLabels_frontier (f : QueryImpl HashSpec Id) (words : OtsReferenceWords)
+    (root : Digest) :
+    canonicalGraphFrontier otsSecret (canonicalGraphLabels parameter otsSecret ftsSecret f) words =
+      canonicalFrontierValues ⟨parameter, root, otsSecret, ftsSecret⟩ f words := by
+  funext lay tree leaf chain
+  simp only [canonicalGraphFrontier, canonicalFrontierValues]
+  split_ifs with hzero
+  · rw [hzero]
+    simp [chainWalk]
+  · rw [canonicalGraphLabels_chain]
+    have hstep : (words lay tree leaf chain).val - 1 + 1 = (words lay tree leaf chain).val := by omega
+    simp only [hstep, honestChain]
+
+end Concrete
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalGraphResidual.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalGraphResidual.lean
new file mode 100644
index 000000000..16440ca6a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalGraphResidual.lean
@@ -0,0 +1,113 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.CanonicalGraphSampling
+import SphincsSecurity.Proof.Hypertree.FiniteGraphReplay
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec OracleComp.DeferredSampling FiniteGraphSampling
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalGraphInputs canonicalPayloadInputs canonicalGraphOrder instFintypePosition
+
+noncomputable local instance residualGraphTableSampleable (inputs : Finset HashInput) : SampleableType (inputs → HashOutput) :=
+  SampleableType.ofFintype (inputs → HashOutput)
+
+noncomputable local instance residualGraphLabelsSampleable : SampleableType CanonicalGraphLabels :=
+  SampleableType.ofFintype CanonicalGraphLabels
+
+variable (parameter : PublicParameter)
+  (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+  (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+  (inputs : Finset HashInput) (hinputs : canonicalGraphInputs parameter ⊆ inputs)
+
+noncomputable def programCanonicalGraph (labels : CanonicalGraphLabels) (residual : inputs → HashOutput) : inputs → HashOutput :=
+  patch (fun position => canonicalGraphCell parameter otsSecret ftsSecret inputs hinputs position labels)
+    labels residual canonicalGraphOrder
+
+theorem canonicalGraphCell_injective (labels : CanonicalGraphLabels) :
+    Function.Injective (fun position => canonicalGraphCell parameter otsSecret ftsSecret inputs hinputs position labels) := by
+  intro left right heq
+  by_contra hne
+  exact canonicalGraphCell_separated parameter otsSecret ftsSecret inputs hinputs left right hne labels labels heq
+
+theorem programCanonicalGraph_at (labels : CanonicalGraphLabels) (residual : inputs → HashOutput) (position : Position) :
+    programCanonicalGraph parameter otsSecret ftsSecret inputs hinputs labels residual
+      (canonicalGraphCell parameter otsSecret ftsSecret inputs hinputs position labels) = labels position :=
+  patch_at _ (canonicalGraphCell_injective parameter otsSecret ftsSecret inputs hinputs labels)
+    labels residual canonicalGraphOrder position (mem_canonicalGraphOrder position)
+
+theorem programCanonicalGraph_other (labels : CanonicalGraphLabels) (residual : inputs → HashOutput)
+    (input : inputs) (hne : ∀ position, input.val ≠ canonicalGraphInput parameter otsSecret ftsSecret position labels) :
+    programCanonicalGraph parameter otsSecret ftsSecret inputs hinputs labels residual input = residual input := by
+  apply patch_of_forall_ne
+  intro position _ heq
+  exact hne position (congrArg Subtype.val heq)
+
+theorem replayCanonicalGraph_eq_patch (labels : CanonicalGraphLabels) (residual : inputs → HashOutput)
+    (positions : List Position) (hsorted : positions.Pairwise (fun left right => left.depth ≤ right.depth))
+    (before : CanonicalGraphLabels) (hagrees : ∀ position, position ∉ positions → before position = labels position) :
+    replay (canonicalGraphCell parameter otsSecret ftsSecret inputs hinputs)
+      (fun position output values => Function.update values position output) labels residual positions before =
+      (labels, patch (fun position => canonicalGraphCell parameter otsSecret ftsSecret inputs hinputs position labels)
+        labels residual positions) := by
+  induction positions generalizing before with
+  | nil =>
+      have hbefore : before = labels := by
+        funext position
+        exact hagrees position (by simp)
+      rw [hbefore]
+      rfl
+  | cons first rest ih =>
+      obtain ⟨hdepth, hsorted⟩ := List.pairwise_cons.mp hsorted
+      have hinput : canonicalGraphCell parameter otsSecret ftsSecret inputs hinputs first before =
+          canonicalGraphCell parameter otsSecret ftsSecret inputs hinputs first labels := by
+        apply Subtype.ext
+        apply canonicalGraphInput_congr
+        intro child hchild
+        apply congrArg truncateHash
+        apply hagrees
+        intro hmem
+        have hlt := Position.depth_lt_of_mem_children hchild
+        rcases List.mem_cons.mp hmem with heq | hmem
+        · subst child
+          omega
+        · have := hdepth child hmem
+          omega
+      have hafter : ∀ position, position ∉ rest →
+          Function.update before first (labels first) position = labels position := by
+        intro position hposition
+        by_cases heq : position = first
+        · subst position
+          rw [Function.update_self]
+        · rw [Function.update_of_ne heq]
+          exact hagrees position (fun hmem => (List.mem_cons.mp hmem).elim heq hposition)
+      rw [replay, ih hsorted _ hafter, patch, hinput]
+
+theorem evalDist_plantCanonicalGraph_eq_residual :
+    𝒟[plantCanonicalGraph parameter otsSecret ftsSecret inputs hinputs] =
+      𝒟[do
+        let labels ← ($ᵗ CanonicalGraphLabels : ProbComp _)
+        let residual ← sampleHashTable inputs
+        pure (labels, programCanonicalGraph parameter otsSecret ftsSecret inputs hinputs labels residual)] := by
+  rw [plantCanonicalGraph, evalDist_plant_eq_replay _ _ _ canonicalGraphOrder_nodup]
+  simp only [sampleHashTable]
+  apply evalDist_bind_congr_left
+  intro labels
+  apply evalDist_bind_congr_left
+  intro residual
+  rw [replayCanonicalGraph_eq_patch parameter otsSecret ftsSecret inputs hinputs labels residual
+    canonicalGraphOrder canonicalGraphOrder_sorted _
+    (fun position hposition => (hposition (mem_canonicalGraphOrder position)).elim)]
+  rfl
+
+theorem evalDist_plantCanonicalGraph_bind_eq_residual {Result : Type}
+    (next : CanonicalGraphLabels → (inputs → HashOutput) → ProbComp Result) :
+    𝒟[do let graph ← plantCanonicalGraph parameter otsSecret ftsSecret inputs hinputs; next graph.1 graph.2] =
+      𝒟[do
+        let labels ← ($ᵗ CanonicalGraphLabels : ProbComp _)
+        let residual ← sampleHashTable inputs
+        next labels (programCanonicalGraph parameter otsSecret ftsSecret inputs hinputs labels residual)] := by
+  have h := congrArg (fun distribution : SPMF (CanonicalGraphLabels × (inputs → HashOutput)) =>
+    distribution >>= fun graph => 𝒟[next graph.1 graph.2])
+    (evalDist_plantCanonicalGraph_eq_residual parameter otsSecret ftsSecret inputs hinputs)
+  simpa only [evalDist_bind, evalDist_pure, bind_assoc, pure_bind] using h
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalGraphSampling.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalGraphSampling.lean
new file mode 100644
index 000000000..afa11732f
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalGraphSampling.lean
@@ -0,0 +1,118 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.CanonicalGraph
+import SphincsSecurity.Proof.Reference.FiniteHashWorld
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec OracleComp.DeferredSampling
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable local instance instSampleableTypeForallSubtypeHashInputMemFinsetHashOutput_1 (inputs : Finset HashInput) : SampleableType (inputs → HashOutput) :=
+  SampleableType.ofFintype (inputs → HashOutput)
+
+noncomputable local instance instSampleableTypeCanonicalGraphLabels : SampleableType CanonicalGraphLabels :=
+  SampleableType.ofFintype CanonicalGraphLabels
+
+noncomputable def canonicalPayloadInputs : Finset HashInput :=
+  (Finset.range (numChains + 1)).biUnion fun length =>
+    (Finset.univ : Finset (Fin length → Digest)).image (fun values => (List.ofFn values).flatMap digestBytes)
+
+attribute [local irreducible] canonicalPayloadInputs
+
+theorem flatMap_mem_canonicalPayloadInputs (values : List Digest) (hvalues : values.length ≤ numChains) :
+    values.flatMap digestBytes ∈ canonicalPayloadInputs := by
+  classical
+  rw [canonicalPayloadInputs, Finset.mem_biUnion]
+  refine ⟨values.length, Finset.mem_range.mpr (by omega), ?_⟩
+  exact Finset.mem_image.mpr ⟨values.get, Finset.mem_univ _, by rw [List.ofFn_get]⟩
+
+noncomputable def canonicalGraphInputs (parameter : PublicParameter) : Finset HashInput :=
+  Finset.univ.biUnion fun position : Position =>
+    canonicalPayloadInputs.image (tweakableHashInput parameter position.domain)
+
+attribute [local irreducible] canonicalGraphInputs
+
+variable (parameter : PublicParameter)
+  (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+  (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+
+theorem canonicalGraphSlots_length_le (labels : CanonicalGraphLabels) (position : Position) :
+    (canonicalGraphSlots otsSecret ftsSecret labels position).length ≤ numChains := by
+  have h := Position.children_length_le position
+  cases position <;> simp only [canonicalGraphSlots] <;>
+    (try split_ifs) <;> simp only [List.length_map, List.length_singleton] <;>
+    first | exact h | decide
+
+theorem canonicalGraphInput_mem (position : Position) (labels : CanonicalGraphLabels) :
+    canonicalGraphInput parameter otsSecret ftsSecret position labels ∈ canonicalGraphInputs parameter := by
+  classical
+  rw [canonicalGraphInputs, Finset.mem_biUnion]
+  simp only [Finset.mem_univ, true_and]
+  refine ⟨position, ?_⟩
+  exact Finset.mem_image.mpr ⟨(canonicalGraphSlots otsSecret ftsSecret labels position).flatMap digestBytes,
+    flatMap_mem_canonicalPayloadInputs _
+    (canonicalGraphSlots_length_le otsSecret ftsSecret labels position), rfl⟩
+
+noncomputable def canonicalGraphCell (inputs : Finset HashInput)
+    (hinputs : canonicalGraphInputs parameter ⊆ inputs)
+    (position : Position) (labels : CanonicalGraphLabels) : inputs :=
+  ⟨canonicalGraphInput parameter otsSecret ftsSecret position labels,
+    hinputs (canonicalGraphInput_mem parameter otsSecret ftsSecret position labels)⟩
+
+theorem canonicalGraphCell_separated (inputs : Finset HashInput)
+    (hinputs : canonicalGraphInputs parameter ⊆ inputs) :
+    FiniteGraphSampling.Separated (canonicalGraphCell parameter otsSecret ftsSecret inputs hinputs) := by
+  intro left right hne before after heq
+  exact canonicalGraphInput_separated parameter otsSecret ftsSecret left right hne before after
+    (congrArg Subtype.val heq)
+
+theorem read_canonicalGraphCell (inputs : Finset HashInput)
+    (hinputs : canonicalGraphInputs parameter ⊆ inputs) (table : inputs → HashOutput)
+    (positions : List Position) (labels : CanonicalGraphLabels) :
+    FiniteGraphSampling.read (canonicalGraphCell parameter otsSecret ftsSecret inputs hinputs)
+      (fun position output values => Function.update values position output) table positions labels =
+      readCanonicalGraph parameter otsSecret ftsSecret (finiteHashAnswer ∅ inputs table) positions labels := by
+  induction positions generalizing labels with
+  | nil => rfl
+  | cons position positions ih =>
+      have hrow := hinputs (canonicalGraphInput_mem parameter otsSecret ftsSecret position labels)
+      have hanswer := finiteHashAnswer_none ∅ inputs table
+        (canonicalGraphInput parameter otsSecret ftsSecret position labels) hrow (by simp)
+      change FiniteGraphSampling.read _ _ table positions (Function.update labels position
+        (table (canonicalGraphCell parameter otsSecret ftsSecret inputs hinputs position labels))) =
+          readCanonicalGraph parameter otsSecret ftsSecret (finiteHashAnswer ∅ inputs table) positions
+            (Function.update labels position
+              (finiteHashAnswer ∅ inputs table (canonicalGraphInput parameter otsSecret ftsSecret position labels)))
+      rw [ih, hanswer]
+      rfl
+
+noncomputable def plantCanonicalGraph (inputs : Finset HashInput)
+    (hinputs : canonicalGraphInputs parameter ⊆ inputs) : ProbComp (CanonicalGraphLabels × (inputs → HashOutput)) :=
+  FiniteGraphSampling.plant (canonicalGraphCell parameter otsSecret ftsSecret inputs hinputs)
+    (fun position output values => Function.update values position output) canonicalGraphOrder (fun _ => 0)
+
+theorem evalDist_canonicalGraph_eq_plant (inputs : Finset HashInput)
+    (hinputs : canonicalGraphInputs parameter ⊆ inputs) :
+    𝒟[do
+      let table ← sampleHashTable inputs
+      pure (canonicalGraphLabels parameter otsSecret ftsSecret (finiteHashAnswer ∅ inputs table), table)] =
+      𝒟[plantCanonicalGraph parameter otsSecret ftsSecret inputs hinputs] := by
+  have h := FiniteGraphSampling.evalDist_read_eq_plant
+    (canonicalGraphCell parameter otsSecret ftsSecret inputs hinputs)
+    (fun position output values => Function.update values position output)
+    (canonicalGraphCell_separated parameter otsSecret ftsSecret inputs hinputs)
+    canonicalGraphOrder canonicalGraphOrder_nodup (fun _ => 0)
+  simpa only [read_canonicalGraphCell, canonicalGraphLabels, plantCanonicalGraph, sampleHashTable] using h
+
+theorem evalDist_canonicalGraph_bind_eq_plant {Result : Type} (inputs : Finset HashInput)
+    (hinputs : canonicalGraphInputs parameter ⊆ inputs)
+    (next : CanonicalGraphLabels → (inputs → HashOutput) → ProbComp Result) :
+    𝒟[do
+      let table ← sampleHashTable inputs
+      next (canonicalGraphLabels parameter otsSecret ftsSecret (finiteHashAnswer ∅ inputs table)) table] =
+      𝒟[do let result ← plantCanonicalGraph parameter otsSecret ftsSecret inputs hinputs; next result.1 result.2] := by
+  have h := congrArg (fun distribution : SPMF (CanonicalGraphLabels × (inputs → HashOutput)) =>
+    distribution >>= fun result => 𝒟[next result.1 result.2])
+    (evalDist_canonicalGraph_eq_plant parameter otsSecret ftsSecret inputs hinputs)
+  simpa only [evalDist_bind, evalDist_pure, bind_assoc, pure_bind] using h
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalProbeCache.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalProbeCache.lean
new file mode 100644
index 000000000..399246ba7
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalProbeCache.lean
@@ -0,0 +1,86 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.CanonicalProbeRouting
+import SphincsSecurity.Proof.Residual.RetainedObservation
+namespace SphincsSecurity.Concrete.CanonicalProbeRouting
+
+open _root_.OracleComp HiddenLabelObservation RetainedObservation
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+abbrev ExternalCache := HashInput → Option HashOutput
+
+def CacheClean (parameter : PublicParameter) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (actual : Labels) (cache : ExternalCache) : Prop :=
+  ∀ input answer, cache input = some answer → ¬Bad parameter words disclosed actual input answer
+
+theorem hidden_mono (words : OtsReferenceWords) (before after : Index → FtsTree → FtsLeaf → Prop)
+    (hdisclosed : ∀ index tree leaf, before index tree leaf → after index tree leaf) (coordinate : CanonicalCoordinate) :
+    CanonicalCoordinate.Hidden words after coordinate → CanonicalCoordinate.Hidden words before coordinate := by
+  cases coordinate with
+  | otsStart => exact id
+  | graph position => cases position <;> exact id
+  | ftsStart index tree leaf =>
+      intro hhidden hbefore
+      exact hhidden (hdisclosed index tree leaf hbefore)
+
+theorem bad_mono (parameter : PublicParameter) (words : OtsReferenceWords)
+    (before after : Index → FtsTree → FtsLeaf → Prop)
+    (hdisclosed : ∀ index tree leaf, before index tree leaf → after index tree leaf)
+    (actual : Labels) (input : HashInput) (answer : HashOutput) :
+    Bad parameter words after actual input answer → Bad parameter words before actual input answer := by
+  rintro ⟨position, hat, hbad⟩
+  refine ⟨position, hat, ?_⟩
+  rcases hbad with ⟨⟨coordinate, hslot, hhidden⟩, hinput⟩ | houtput
+  · exact Or.inl ⟨⟨coordinate, hslot, hidden_mono words before after hdisclosed coordinate hhidden⟩, hinput⟩
+  · exact Or.inr houtput
+
+theorem cacheClean_disclose (parameter : PublicParameter) (words : OtsReferenceWords)
+    (before after : Index → FtsTree → FtsLeaf → Prop)
+    (hdisclosed : ∀ index tree leaf, before index tree leaf → after index tree leaf)
+    (actual : Labels) (cache : ExternalCache) (hclean : CacheClean parameter words before actual cache) :
+    CacheClean parameter words after actual cache := by
+  intro input answer hcache hbad
+  exact hclean input answer hcache (bad_mono parameter words before after hdisclosed actual input answer hbad)
+
+theorem cacheClean_store (parameter : PublicParameter) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (actual : Labels) (cache : ExternalCache)
+    (hclean : CacheClean parameter words disclosed actual cache) (input : HashInput) (answer : HashOutput)
+    (hsafe : ¬Bad parameter words disclosed actual input answer) :
+    CacheClean parameter words disclosed actual (Function.update cache input (some answer)) := by
+  intro other output hcache
+  by_cases heq : other = input
+  · subst other
+    rw [Function.update_self] at hcache
+    have heq := Option.some.inj hcache
+    exact heq ▸ hsafe
+  · rw [Function.update_of_ne heq] at hcache
+    exact hclean other output hcache
+
+structure ExternalMemory where
+  cache : ExternalCache
+  hashCalls : Nat
+  probes : Nat
+
+noncomputable def charge (parameter : PublicParameter) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels) (input : HashInput)
+    (memory : ExternalMemory) : ExternalMemory :=
+  { memory with
+    hashCalls := memory.hashCalls + 1
+    probes := memory.probes + match memory.cache input with
+      | some _ => 0
+      | none => match route parameter words disclosed known input with
+        | .probe _ => 1
+        | _ => 0 }
+
+noncomputable def storeReply (memory : ExternalMemory) (input : HashInput) (answer : HashOutput) : ExternalMemory :=
+  { memory with cache := Function.update memory.cache input (some answer) }
+
+theorem charge_probes_le (parameter : PublicParameter) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels) (input : HashInput) (memory : ExternalMemory) :
+    (charge parameter words disclosed known input memory).probes ≤ memory.probes + 1 := by
+  unfold charge
+  cases hcache : memory.cache input with
+  | some answer => exact Nat.le_add_right _ _
+  | none => cases route parameter words disclosed known input <;> simp
+
+end SphincsSecurity.Concrete.CanonicalProbeRouting
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalProbeRouting.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalProbeRouting.lean
new file mode 100644
index 000000000..12d966515
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalProbeRouting.lean
@@ -0,0 +1,266 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CanonicalHiddenCoordinates
+import SphincsSecurity.Proof.Ots.EncodingSelectionCache
+import SphincsSecurity.Proof.Scheme.FirstBad
+import SphincsSecurity.Proof.Fts.HiddenLabelObservation
+import SphincsSecurity.Proof.Fts.FtsProbeSimulation
+import SphincsSecurity.Proof.Ots.OtsProbeSimulation
+namespace SphincsSecurity.Concrete.CanonicalProbeRouting
+
+open _root_.OracleComp OracleSpec HiddenLabelObservation
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+abbrev Labels := CanonicalCoordinate → Digest
+
+def inputOf (parameter : PublicParameter) (values : Labels) (position : Position) : HashInput :=
+  tweakableHashInput parameter position.domain
+    (((CanonicalCoordinate.slots position).map values).flatMap digestBytes)
+
+theorem inputOf_canonical (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (labels : CanonicalGraphLabels) (position : Position) :
+    inputOf parameter (CanonicalCoordinate.value otsSecret ftsSecret labels) position =
+      canonicalGraphInput parameter otsSecret ftsSecret position labels := by
+  rw [inputOf, CanonicalCoordinate.values_slots, canonicalGraphInput]
+
+theorem inputOf_unary (parameter : PublicParameter) (values : Labels) (position : Position)
+    (coordinate : CanonicalCoordinate) (hslot : CanonicalCoordinate.slots position = [coordinate]) :
+    inputOf parameter values position = tweakableHashInput parameter position.domain (digestBytes (values coordinate)) := by
+  simp only [inputOf, hslot, List.map_cons, List.map_nil, List.flatMap_cons, List.flatMap_nil, List.append_nil]
+
+theorem unary_eq_inputOf_iff (parameter : PublicParameter) (values : Labels) (position : Position)
+    (coordinate : CanonicalCoordinate) (hslot : CanonicalCoordinate.slots position = [coordinate]) (candidate : Digest) :
+    tweakableHashInput parameter position.domain (digestBytes candidate) = inputOf parameter values position ↔
+      candidate = values coordinate := by
+  rw [inputOf_unary parameter values position coordinate hslot]
+  constructor
+  · intro h
+    exact digestBytes_injective (tweakableHashInput_injective parameter position.domain_inRange position.domain_inRange h).2
+  · rintro rfl
+    rfl
+
+noncomputable def decodePosition (parameter : PublicParameter) (input : HashInput) : Option Position :=
+  letI : Decidable (∃ position, AtPosition parameter input position) := Classical.propDecidable _
+  if h : ∃ position, AtPosition parameter input position then some h.choose else none
+
+theorem decodePosition_some_iff (parameter : PublicParameter) (input : HashInput) (position : Position) :
+    decodePosition parameter input = some position ↔ AtPosition parameter input position := by
+  unfold decodePosition
+  split
+  · rename_i h
+    constructor
+    · intro heq
+      have heq := Option.some.inj heq
+      exact heq ▸ h.choose_spec
+    · intro hat
+      exact congrArg some (atPosition_unique parameter h.choose_spec hat)
+  · rename_i h
+    constructor
+    · simp
+    · intro hat
+      exact (h ⟨position, hat⟩).elim
+
+theorem decodePosition_none_iff (parameter : PublicParameter) (input : HashInput) :
+    decodePosition parameter input = none ↔ ∀ position, ¬AtPosition parameter input position := by
+  constructor
+  · intro hnone position hat
+    have hsome := (decodePosition_some_iff parameter input position).mpr hat
+    rw [hnone] at hsome
+    cases hsome
+  · intro hnone
+    cases hdecode : decodePosition parameter input with
+    | none => rfl
+    | some position => exact (hnone position ((decodePosition_some_iff parameter input position).mp hdecode)).elim
+
+noncomputable def decodeUnary (parameter : PublicParameter) (position : Position) (input : HashInput) : Option Digest :=
+  letI : Decidable (∃ value, input = tweakableHashInput parameter position.domain (digestBytes value)) := Classical.propDecidable _
+  if h : ∃ value, input = tweakableHashInput parameter position.domain (digestBytes value) then some h.choose else none
+
+theorem decodeUnary_some_iff (parameter : PublicParameter) (position : Position) (input : HashInput) (candidate : Digest) :
+    decodeUnary parameter position input = some candidate ↔
+      input = tweakableHashInput parameter position.domain (digestBytes candidate) := by
+  unfold decodeUnary
+  split
+  · rename_i h
+    constructor
+    · intro heq
+      have heq := Option.some.inj heq
+      exact heq ▸ h.choose_spec
+    · intro hinput
+      apply congrArg some
+      exact digestBytes_injective
+        (tweakableHashInput_injective parameter position.domain_inRange position.domain_inRange
+          (h.choose_spec.symm.trans hinput)).2
+  · rename_i h
+    constructor
+    · simp
+    · intro hinput
+      exact (h ⟨candidate, hinput⟩).elim
+
+theorem decodeUnary_none_ne (parameter : PublicParameter) (position : Position) (input : HashInput)
+    (hnone : decodeUnary parameter position input = none) (candidate : Digest) :
+    input ≠ tweakableHashInput parameter position.domain (digestBytes candidate) := by
+  intro hinput
+  have hsome := (decodeUnary_some_iff parameter position input candidate).mpr hinput
+  rw [hnone] at hsome
+  cases hsome
+
+def HasHiddenChild (words : OtsReferenceWords) (disclosed : Index → FtsTree → FtsLeaf → Prop)
+    (position : Position) : Prop :=
+  ∃ coordinate ∈ CanonicalCoordinate.slots position, CanonicalCoordinate.Hidden words disclosed coordinate
+
+def PublicAgreement (words : OtsReferenceWords) (disclosed : Index → FtsTree → FtsLeaf → Prop)
+    (known actual : Labels) : Prop :=
+  ∀ coordinate, ¬CanonicalCoordinate.Hidden words disclosed coordinate → known coordinate = actual coordinate
+
+theorem inputOf_public (parameter : PublicParameter) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known actual : Labels)
+    (hagrees : PublicAgreement words disclosed known actual) (position : Position)
+    (hpublic : ¬HasHiddenChild words disclosed position) :
+    inputOf parameter known position = inputOf parameter actual position := by
+  have hvalues : (CanonicalCoordinate.slots position).map known = (CanonicalCoordinate.slots position).map actual := by
+    apply List.map_congr_left
+    intro coordinate hcoordinate
+    exact hagrees coordinate (fun hhidden => hpublic ⟨coordinate, hcoordinate, hhidden⟩)
+  rw [inputOf, inputOf, hvalues]
+
+theorem parent_public_of_no_hidden_child (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (position : Position)
+    (hpublic : ¬HasHiddenChild words disclosed position) :
+    ¬CanonicalCoordinate.Hidden words disclosed (.graph position) := by
+  intro hhidden
+  cases position
+  case chain lay tree leaf chain step =>
+    apply hpublic
+    refine ⟨CanonicalCoordinate.chainChild lay tree leaf chain step, ?_, ?_⟩
+    · rw [CanonicalCoordinate.slots_chain]
+      exact List.mem_singleton_self _
+    · apply (CanonicalCoordinate.hidden_chain_child_iff words disclosed lay tree leaf chain step).mpr
+      change step.val + 1 < (words lay tree leaf chain).val at hhidden
+      omega
+  all_goals exact hhidden
+
+inductive Route where
+  | outside
+  | canonical (position : Position)
+  | probe (request : Probe CanonicalCoordinate)
+
+noncomputable def routeAt (parameter : PublicParameter) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels) (position : Position) (input : HashInput) : Route :=
+  if h : HasHiddenChild words disclosed position then
+    match decodeUnary parameter position input with
+    | some candidate => .probe (.pair h.choose (.graph position)
+        (CanonicalCoordinate.slots_ne_parent position h.choose h.choose_spec.1) candidate)
+    | none => .probe (.output (.graph position))
+  else if input = inputOf parameter known position then .canonical position else .probe (.output (.graph position))
+
+noncomputable def route (parameter : PublicParameter) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels) (input : HashInput) : Route :=
+  (decodePosition parameter input).elim .outside (fun position => routeAt parameter words disclosed known position input)
+
+def RouteSpec (parameter : PublicParameter) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (actual : Labels) (input : HashInput) : Route → Prop
+  | .outside => ∀ position, ¬AtPosition parameter input position
+  | .canonical position => AtPosition parameter input position ∧ input = inputOf parameter actual position ∧
+      ¬HasHiddenChild words disclosed position
+  | .probe (.pair child parent _ candidate) => ∃ position, AtPosition parameter input position ∧ parent = .graph position ∧
+      CanonicalCoordinate.slots position = [child] ∧ CanonicalCoordinate.Hidden words disclosed child ∧
+      input = tweakableHashInput parameter position.domain (digestBytes candidate)
+  | .probe (.output parent) => ∃ position, AtPosition parameter input position ∧ parent = .graph position ∧
+      input ≠ inputOf parameter actual position
+
+theorem routeAt_spec (parameter : PublicParameter) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known actual : Labels)
+    (hagrees : PublicAgreement words disclosed known actual) (position : Position) (input : HashInput)
+    (hat : AtPosition parameter input position) :
+    RouteSpec parameter words disclosed actual input (routeAt parameter words disclosed known position input) := by
+  unfold routeAt
+  split
+  · rename_i hhidden
+    have hslot := CanonicalCoordinate.hidden_slot_unary words disclosed position hhidden.choose
+      hhidden.choose_spec.1 hhidden.choose_spec.2
+    cases hdecode : decodeUnary parameter position input with
+    | none =>
+        refine ⟨position, hat, rfl, ?_⟩
+        rw [inputOf_unary parameter actual position hhidden.choose hslot]
+        exact decodeUnary_none_ne parameter position input hdecode _
+    | some candidate =>
+        exact ⟨position, hat, rfl, hslot, hhidden.choose_spec.2,
+          (decodeUnary_some_iff parameter position input candidate).mp hdecode⟩
+  · rename_i hpublic
+    have heq := inputOf_public parameter words disclosed known actual hagrees position hpublic
+    split
+    · rename_i hinput
+      exact ⟨hat, hinput.trans heq, hpublic⟩
+    · rename_i hinput
+      exact ⟨position, hat, rfl, fun h => hinput (h.trans heq.symm)⟩
+
+theorem route_spec (parameter : PublicParameter) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known actual : Labels)
+    (hagrees : PublicAgreement words disclosed known actual) (input : HashInput) :
+    RouteSpec parameter words disclosed actual input (route parameter words disclosed known input) := by
+  rw [route]
+  cases hdecode : decodePosition parameter input with
+  | none => exact (decodePosition_none_iff parameter input).mp hdecode
+  | some position =>
+      exact routeAt_spec parameter words disclosed known actual hagrees position input
+        ((decodePosition_some_iff parameter input position).mp hdecode)
+
+def BadAt (parameter : PublicParameter) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (actual : Labels)
+    (position : Position) (input : HashInput) (answer : HashOutput) : Prop :=
+  (HasHiddenChild words disclosed position ∧ input = inputOf parameter actual position) ∨
+    (input ≠ inputOf parameter actual position ∧ truncateHash answer = actual (.graph position))
+
+def Bad (parameter : PublicParameter) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (actual : Labels) (input : HashInput) (answer : HashOutput) : Prop :=
+  ∃ position, AtPosition parameter input position ∧ BadAt parameter words disclosed actual position input answer
+
+theorem bad_iff_at (parameter : PublicParameter) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (actual : Labels) (position : Position)
+    (input : HashInput) (hat : AtPosition parameter input position) (answer : HashOutput) :
+    Bad parameter words disclosed actual input answer ↔ BadAt parameter words disclosed actual position input answer := by
+  constructor
+  · rintro ⟨other, hother, hbad⟩
+    have heq := atPosition_unique parameter hother hat
+    exact heq ▸ hbad
+  · intro hbad
+    exact ⟨position, hat, hbad⟩
+
+def Safe (actual : Labels) (answer : HashOutput) : Route → Prop
+  | .probe request => request.keep actual answer
+  | _ => True
+
+theorem safe_iff_not_bad (parameter : PublicParameter) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (actual : Labels) (input : HashInput)
+    (routing : Route) (hspec : RouteSpec parameter words disclosed actual input routing) (answer : HashOutput) :
+    Safe actual answer routing ↔ ¬Bad parameter words disclosed actual input answer := by
+  cases routing with
+  | outside =>
+      constructor
+      · intro _ hbad
+        obtain ⟨position, hat, _⟩ := hbad
+        exact hspec position hat
+      · intro _
+        trivial
+  | canonical position =>
+      obtain ⟨hat, hinput, hpublic⟩ := hspec
+      rw [bad_iff_at parameter words disclosed actual position input hat answer]
+      simp only [Safe, BadAt, hinput, hpublic, false_and, ne_eq, not_true_eq_false, or_self, not_false_eq_true]
+  | probe request =>
+      cases request with
+      | pair child parent hne candidate =>
+          obtain ⟨position, hat, rfl, hslot, hhidden, hinput⟩ := hspec
+          have hhas : HasHiddenChild words disclosed position := ⟨child, by rw [hslot]; exact List.mem_singleton_self _, hhidden⟩
+          have heq : input = inputOf parameter actual position ↔ candidate = actual child := by
+            rw [hinput, unary_eq_inputOf_iff parameter actual position child hslot candidate]
+          rw [bad_iff_at parameter words disclosed actual position input hat answer]
+          simp only [Safe, Probe.keep, BadAt, hhas, true_and, heq]
+          tauto
+      | output parent =>
+          obtain ⟨position, hat, rfl, hinput⟩ := hspec
+          rw [bad_iff_at parameter words disclosed actual position input hat answer]
+          simp only [Safe, Probe.keep, BadAt, hinput, and_false, not_false_eq_true, true_and, false_or, ne_eq, eq_comm]
+
+end SphincsSecurity.Concrete.CanonicalProbeRouting
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalPublicPrior.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalPublicPrior.lean
new file mode 100644
index 000000000..e08609e44
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalPublicPrior.lean
@@ -0,0 +1,78 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CanonicalCoordinateSampling
+import SphincsSecurity.Proof.Hypertree.CanonicalProbeRouting
+import SphincsSecurity.Proof.Residual.RetainedObservation
+import SphincsSecurity.Proof.Fts.UniformPublicCoordinates
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting UniformTableCompletion
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+def initiallyExposed (words : OtsReferenceWords) (coordinate : CanonicalCoordinate) : Prop :=
+  ¬CanonicalCoordinate.Hidden words (fun _ _ _ => False) coordinate
+
+abbrev InitialPublicLabels (words : OtsReferenceWords) :=
+  UniformPublicCoordinates.Public (initiallyExposed words) → Digest
+
+noncomputable def initialKnown (words : OtsReferenceWords) (exposedValues : InitialPublicLabels words) : Labels :=
+  fun coordinate => if h : initiallyExposed words coordinate then exposedValues ⟨coordinate, h⟩ else 0
+
+noncomputable def initialAllowed (words : OtsReferenceWords) (exposedValues : InitialPublicLabels words) :
+    CanonicalCoordinate → Finset Digest :=
+  UniformPublicCoordinates.allowed (initiallyExposed words) exposedValues
+
+theorem initialAllowed_nonempty (words : OtsReferenceWords) (exposedValues : InitialPublicLabels words) :
+    ∀ coordinate, (initialAllowed words exposedValues coordinate).Nonempty :=
+  UniformPublicCoordinates.allowed_nonempty (initiallyExposed words) exposedValues
+
+theorem initialAllowed_hidden (words : OtsReferenceWords) (exposedValues : InitialPublicLabels words)
+    (coordinate : CanonicalCoordinate) (hhidden : CanonicalCoordinate.Hidden words (fun _ _ _ => False) coordinate) :
+    initialAllowed words exposedValues coordinate = Finset.univ := by
+  unfold initialAllowed UniformPublicCoordinates.allowed
+  exact dif_neg (not_not.mpr hhidden)
+
+theorem initialAllowed_public (words : OtsReferenceWords) (exposedValues : InitialPublicLabels words)
+    (coordinate : CanonicalCoordinate) (hpublic : initiallyExposed words coordinate) :
+    initialAllowed words exposedValues coordinate = {initialKnown words exposedValues coordinate} := by
+  simp only [initialAllowed, UniformPublicCoordinates.allowed, initialKnown, dif_pos hpublic]
+
+theorem initialKnown_agrees (words : OtsReferenceWords) (exposedValues : InitialPublicLabels words)
+    (labels : Labels) (hlabels : complete (initialAllowed words exposedValues) labels ≠ 0) :
+    PublicAgreement words (fun _ _ _ => False) (initialKnown words exposedValues) labels := by
+  intro coordinate hpublic
+  have hmem := UniformPublicCoordinates.completion_member (initialAllowed words exposedValues) labels hlabels coordinate
+  rw [initialAllowed_public words exposedValues coordinate hpublic, Finset.mem_singleton] at hmem
+  exact hmem.symm
+
+theorem initialKnown_graphReplies (words : OtsReferenceWords) (exposedValues : InitialPublicLabels words)
+    (labels : Labels) (hlabels : complete (initialAllowed words exposedValues) labels ≠ 0)
+    (high : CanonicalGraphHighHalves) (position : Position)
+    (hpublic : initiallyExposed words (.graph position)) :
+    coordinateGraphLabels (initialKnown words exposedValues) high position = coordinateGraphLabels labels high position := by
+  unfold coordinateGraphLabels
+  rw [initialKnown_agrees words exposedValues labels hlabels (.graph position) hpublic]
+
+theorem sampleSecretGraph_bind_public {Result : Type} (words : OtsReferenceWords)
+    (next : InitialPublicLabels words → CanonicalGraphHighHalves →
+      (Layer → TreeIndex → LeafIndex → ChainIndex → Digest) →
+      (Index → FtsTree → FtsLeaf → Digest) → CanonicalGraphLabels → SPMF Result) :
+    (𝒟[sampleOtsSecrets] >>= fun ots => 𝒟[sampleFtsSecrets] >>= fun fts =>
+      𝒟[PMF.uniformOfFintype CanonicalGraphLabels] >>= fun graph =>
+        next (UniformPublicCoordinates.restrict (initiallyExposed words) (CanonicalCoordinate.value ots fts graph))
+          (canonicalGraphHighHalves graph) ots fts graph) =
+        (𝒟[PMF.uniformOfFintype CanonicalGraphHighHalves] >>= fun high =>
+          𝒟[PMF.uniformOfFintype (InitialPublicLabels words)] >>= fun exposedValues =>
+            complete (initialAllowed words exposedValues) >>= fun labels =>
+              next exposedValues high (coordinateOtsSecrets labels) (coordinateFtsSecrets labels) (coordinateGraphLabels labels high)) := by
+  rw [sampleSecretGraph_bind_coordinates]
+  simp only [coordinateGraphLabels_value, coordinateGraphLabels_high]
+  rw [RetainedObservation.bind_comm]
+  apply congrArg (𝒟[PMF.uniformOfFintype CanonicalGraphHighHalves] >>= ·)
+  funext high
+  exact UniformPublicCoordinates.uniform_bind_complete (initiallyExposed words)
+    (fun exposedValues labels => next exposedValues high (coordinateOtsSecrets labels) (coordinateFtsSecrets labels)
+      (coordinateGraphLabels labels high))
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalSigningFrontier.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalSigningFrontier.lean
new file mode 100644
index 000000000..6b931d320
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/CanonicalSigningFrontier.lean
@@ -0,0 +1,100 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.FrontierSignerErasure
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] referenceEncodingSearch chainWalk boundaryEval
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def referenceIndex (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) : Index :=
+  if h : ∃ index, treeIndexAt index lay = tree ∧ leafIndexAt index lay = leaf then Classical.choose h else 0
+
+theorem referenceIndex_position (index : Index) (lay : Layer) :
+    treeIndexAt (referenceIndex lay (treeIndexAt index lay) (leafIndexAt index lay)) lay = treeIndexAt index lay ∧
+      leafIndexAt (referenceIndex lay (treeIndexAt index lay) (leafIndexAt index lay)) lay = leafIndexAt index lay := by
+  have h : ∃ source, treeIndexAt source lay = treeIndexAt index lay ∧
+      leafIndexAt source lay = leafIndexAt index lay := ⟨index, rfl, rfl⟩
+  rw [referenceIndex, dif_pos h]
+  exact Classical.choose_spec h
+
+theorem layerMessage_referenceIndex (key : SecretKey) (index : Index) (lay : Layer) :
+    layerMessage (m := OracleComp HashSpec) key
+        (referenceIndex lay (treeIndexAt index lay) (leafIndexAt index lay)) lay =
+      layerMessage key index lay :=
+  layerMessage_eq_of_position_eq key _ index lay (referenceIndex_position index lay).1
+    (referenceIndex_position index lay).2
+
+noncomputable def canonicalEncodingSearch (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) : Option (Counter × Encoding) × Nat :=
+  referenceEncodingSearch key.parameter f lay tree leaf
+    (evalWithAnswerFn f (layerMessage key (referenceIndex lay tree leaf) lay)) encodingAttemptLimit 0
+
+theorem canonicalEncodingSearch_at (key : SecretKey) (f : QueryImpl HashSpec Id) (index : Index) (lay : Layer) :
+    canonicalEncodingSearch key f lay (treeIndexAt index lay) (leafIndexAt index lay) =
+      referenceEncodingSearch key.parameter f lay (treeIndexAt index lay) (leafIndexAt index lay)
+        (evalWithAnswerFn f (layerMessage key index lay)) encodingAttemptLimit 0 := by
+  rw [canonicalEncodingSearch, layerMessage_referenceIndex]
+
+noncomputable def canonicalReferenceWords (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (dummy : OtsReferenceWords) : OtsReferenceWords :=
+  fun lay tree leaf => ((canonicalEncodingSearch key f lay tree leaf).1.map Prod.snd).getD (dummy lay tree leaf)
+
+noncomputable def canonicalFrontierValues (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (words : OtsReferenceWords) : OtsFrontierValues :=
+  fun lay tree leaf chainIdx => evalWithAnswerFn f
+    (chainWalk key.parameter lay tree leaf chainIdx 0 (words lay tree leaf chainIdx).val
+      (key.otsSecret lay tree leaf chainIdx))
+
+theorem isSigningFrontier_canonical (key : SecretKey) (f : QueryImpl HashSpec Id) (words : OtsReferenceWords) :
+    IsSigningFrontier key f words (canonicalFrontierValues key f words) := fun _ _ _ _ => rfl
+
+theorem frontierReferenceWord_canonical (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (dummy : OtsReferenceWords) (index : Index) (lay : Layer) :
+    FrontierReferenceWord key.parameter f key.ftsSecret (canonicalReferenceWords key f dummy)
+      (canonicalFrontierValues key f (canonicalReferenceWords key f dummy)) index lay := by
+  intro counter word hword
+  rw [frontierLayerSearch, eval_frontierLayerMessage key f _ _ (isSigningFrontier_canonical key f _) index lay,
+    ← canonicalEncodingSearch_at] at hword
+  simp only [canonicalReferenceWords, hword, Option.map_some, Option.getD_some]
+
+theorem referenceEncodingSearch_valid (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (message : Digest)
+    (attempts start : Nat) (counter : Counter) (word : Encoding)
+    (hword : (referenceEncodingSearch parameter f lay tree leaf message attempts start).1 = some (counter, word)) :
+    TargetSum.Valid word := by
+  induction attempts generalizing start with
+  | zero => simp [referenceEncodingSearch] at hword
+  | succ attempts ih =>
+      cases hencode : evalWithAnswerFn f
+          (encode parameter lay tree leaf message (BitVec.ofNat counterBits start)) with
+      | none =>
+          apply ih (start + 1)
+          simpa only [referenceEncodingSearch, hencode] using hword
+      | some selected =>
+          simp only [referenceEncodingSearch, hencode, Option.some.injEq, Prod.mk.injEq] at hword
+          apply TargetSum.valid_of_decodeDigest_eq_some
+          simpa only [encode, evalWithAnswerFn_bind, evalWithAnswerFn_pure, hword.2] using hencode
+
+theorem canonicalReferenceWords_valid (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (dummy : OtsReferenceWords) (hdummy : ∀ lay tree leaf, TargetSum.Valid (dummy lay tree leaf)) :
+    ∀ lay tree leaf, TargetSum.Valid (canonicalReferenceWords key f dummy lay tree leaf) := by
+  intro lay tree leaf
+  cases hsearch : (canonicalEncodingSearch key f lay tree leaf).1 with
+  | none => simpa only [canonicalReferenceWords, hsearch, Option.map_none, Option.getD_none] using hdummy lay tree leaf
+  | some selected =>
+      obtain ⟨counter, word⟩ := selected
+      simp only [canonicalReferenceWords, hsearch, Option.map_some, Option.getD_some]
+      exact referenceEncodingSearch_valid _ _ _ _ _ _ _ _ _ _ hsearch
+
+theorem boundaryEval_signAfterDigest_canonical (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (dummy : OtsReferenceWords) (randomness : Randomness) (index : Index) (leaves : IndexGroup → FtsLeaf) :
+    let words := canonicalReferenceWords key f dummy
+    let frontier := canonicalFrontierValues key f words
+    let projected := frontierSignAfterDigest key.parameter f key.ftsSecret words frontier randomness index leaves
+    boundaryEval key.parameter f (signAfterDigest key randomness index leaves) =
+      (projected.1, (FreeMonoid.of none) ^ projected.2) :=
+  boundaryEval_signAfterDigest_frontier key f _ _ (isSigningFrontier_canonical key f _) randomness index leaves
+    (frontierReferenceWord_canonical key f dummy index)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/Descent.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/Descent.lean
new file mode 100644
index 000000000..789f43b37
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/Descent.lean
@@ -0,0 +1,208 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Scheme.Cached
+import SphincsSecurity.Proof.Scheme.Charge
+import SphincsSecurity.Proof.Hypertree.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⟩
+
+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)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/Extract.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/Extract.lean
new file mode 100644
index 000000000..4eb3f747b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/Extract.lean
@@ -0,0 +1,130 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Scheme.Arith
+import SphincsSecurity.Proof.Scheme.Bytes
+import SphincsSecurity.Proof.Scheme.StatementLemmas
+/-!
+# 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/Hypertree/FiniteGraphReplay.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/FiniteGraphReplay.lean
new file mode 100644
index 000000000..d7921cbda
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/FiniteGraphReplay.lean
@@ -0,0 +1,105 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.FiniteGraphSampling
+namespace SphincsSecurity.Concrete.FiniteGraphSampling
+
+open _root_.OracleComp OracleSpec OracleComp.DeferredSampling
+set_option backward.isDefEq.respectTransparency false
+
+variable {Node Cell Answer State : Type} [DecidableEq Node] [DecidableEq Cell]
+
+def replay (input : Node → State → Cell) (advance : Node → Answer → State → State)
+    (answers : Node → Answer) (table : Cell → Answer) : List Node → State → State × (Cell → Answer)
+  | [], state => (state, table)
+  | node :: nodes, state =>
+      let result := replay input advance answers table nodes (advance node (answers node) state)
+      (result.1, Function.update result.2 (input node state) (answers node))
+
+omit [DecidableEq Node] in
+theorem replay_congr (input : Node → State → Cell) (advance : Node → Answer → State → State)
+    (left right : Node → Answer) (table : Cell → Answer) (nodes : List Node)
+    (hagrees : ∀ node ∈ nodes, left node = right node) (state : State) :
+    replay input advance left table nodes state = replay input advance right table nodes state := by
+  induction nodes generalizing state with
+  | nil => rfl
+  | cons node nodes ih =>
+      have hfirst := hagrees node List.mem_cons_self
+      have hrest := ih (fun other hother => hagrees other (List.mem_cons_of_mem _ hother))
+      simp only [replay, hfirst, hrest]
+
+theorem replay_update_of_not_mem (input : Node → State → Cell) (advance : Node → Answer → State → State)
+    (answers : Node → Answer) (table : Cell → Answer) (nodes : List Node)
+    (node : Node) (hnode : node ∉ nodes) (answer : Answer) (state : State) :
+    replay input advance (Function.update answers node answer) table nodes state =
+      replay input advance answers table nodes state := by
+  apply replay_congr
+  intro other hother
+  have hne : other ≠ node := by
+    intro heq
+    subst other
+    exact hnode hother
+  rw [Function.update_of_ne hne]
+
+def patch (input : Node → Cell) (answers : Node → Answer) (table : Cell → Answer) : List Node → Cell → Answer
+  | [] => table
+  | node :: nodes => Function.update (patch input answers table nodes) (input node) (answers node)
+
+omit [DecidableEq Node] in
+theorem patch_of_forall_ne (input : Node → Cell) (answers : Node → Answer) (table : Cell → Answer)
+    (nodes : List Node) (cell : Cell) (hne : ∀ node ∈ nodes, cell ≠ input node) :
+    patch input answers table nodes cell = table cell := by
+  induction nodes with
+  | nil => rfl
+  | cons node nodes ih =>
+      rw [patch, Function.update_of_ne (hne node List.mem_cons_self)]
+      exact ih (fun other hother => hne other (List.mem_cons_of_mem _ hother))
+
+theorem patch_at (input : Node → Cell) (hinjective : Function.Injective input)
+    (answers : Node → Answer) (table : Cell → Answer) (nodes : List Node) (node : Node) (hnode : node ∈ nodes) :
+    patch input answers table nodes (input node) = answers node := by
+  induction nodes with
+  | nil => cases hnode
+  | cons first rest ih =>
+      by_cases heq : node = first
+      · subst node
+        exact Function.update_self _ _ _
+      · rw [patch, Function.update_of_ne (fun h => heq (hinjective h))]
+        exact ih ((List.mem_cons.mp hnode).resolve_left heq)
+
+variable [_root_.Finite Node] [_root_.Finite Cell] [_root_.Finite Answer] [Nonempty Answer]
+  [SampleableType Answer] [SampleableType (Node → Answer)] [SampleableType (Cell → Answer)]
+
+omit [_root_.Finite Cell] in
+theorem evalDist_plant_eq_replay (input : Node → State → Cell) (advance : Node → Answer → State → State)
+    (nodes : List Node) (hnodes : nodes.Nodup) (state : State) :
+    𝒟[plant input advance nodes state] =
+      𝒟[do
+        let answers ← ($ᵗ (Node → Answer) : ProbComp _)
+        let table ← ($ᵗ (Cell → Answer) : ProbComp _)
+        pure (replay input advance answers table nodes state)] := by
+  induction nodes generalizing state with
+  | nil =>
+      simp only [plant, replay]
+      exact (evalDist_bind_const_neverFails _ (by simp) _).symm
+  | cons node nodes ih =>
+      obtain ⟨hnode, hnodes⟩ := List.nodup_cons.mp hnodes
+      have hextract := evalDist_table_extract node (fun answers answer => do
+        let table ← ($ᵗ (Cell → Answer) : ProbComp _)
+        let result := replay input advance answers table nodes (advance node answer state)
+        pure (result.1, Function.update result.2 (input node state) answer))
+      change 𝒟[plant input advance (node :: nodes) state] =
+        𝒟[do
+          let answers ← ($ᵗ (Node → Answer) : ProbComp _)
+          let table ← ($ᵗ (Cell → Answer) : ProbComp _)
+          let result := replay input advance answers table nodes (advance node (answers node) state)
+          pure (result.1, Function.update result.2 (input node state) (answers node))]
+      rw [hextract]
+      simp_rw [replay_update_of_not_mem input advance _ _ nodes node hnode]
+      simp only [plant]
+      apply evalDist_bind_congr_left
+      intro answer
+      have h := congrArg (fun distribution : SPMF (State × (Cell → Answer)) =>
+        distribution >>= fun result => pure (result.1, Function.update result.2 (input node state) answer))
+        (ih hnodes (advance node answer state))
+      simpa only [evalDist_bind, evalDist_pure, bind_assoc, pure_bind] using h
+
+end SphincsSecurity.Concrete.FiniteGraphSampling
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/FiniteGraphSampling.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/FiniteGraphSampling.lean
new file mode 100644
index 000000000..e3cf3910d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/FiniteGraphSampling.lean
@@ -0,0 +1,95 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.Honest
+namespace SphincsSecurity.Concrete.FiniteGraphSampling
+
+open _root_.OracleComp OracleSpec OracleComp.DeferredSampling
+set_option backward.isDefEq.respectTransparency false
+
+variable {Node Cell Answer State : Type} [DecidableEq Cell]
+
+def read (input : Node → State → Cell) (advance : Node → Answer → State → State)
+    (table : Cell → Answer) : List Node → State → State
+  | [], state => state
+  | node :: nodes, state => read input advance table nodes (advance node (table (input node state)) state)
+
+def Separated (input : Node → State → Cell) : Prop :=
+  ∀ left right, left ≠ right → ∀ before after, input left before ≠ input right after
+
+omit [DecidableEq Cell] in
+theorem read_congr (input : Node → State → Cell) (advance : Node → Answer → State → State)
+    (left right : Cell → Answer) (hagrees : ∀ node state, left (input node state) = right (input node state))
+    (nodes : List Node) (state : State) : read input advance left nodes state = read input advance right nodes state := by
+  induction nodes generalizing state with
+  | nil => rfl
+  | cons node nodes ih =>
+      simp only [read, hagrees]
+      exact ih _
+
+theorem read_update_of_not_mem (input : Node → State → Cell)
+    (advance : Node → Answer → State → State) (hsep : Separated input)
+    (table : Cell → Answer) (nodes : List Node) (node : Node) (hnode : node ∉ nodes)
+    (before state : State) (answer : Answer) :
+    read input advance (Function.update table (input node before) answer) nodes state =
+      read input advance table nodes state := by
+  induction nodes generalizing state with
+  | nil => rfl
+  | cons first rest ih =>
+      have hne : first ≠ node := fun h => hnode (by simp [h])
+      have hrest : node ∉ rest := fun h => hnode (List.mem_cons_of_mem _ h)
+      simp only [read, Function.update_of_ne (hsep first node hne state before)]
+      exact ih hrest _
+
+variable [_root_.Finite Cell] [_root_.Finite Answer] [Nonempty Answer]
+  [SampleableType Answer] [SampleableType (Cell → Answer)]
+
+noncomputable def plant (input : Node → State → Cell)
+    (advance : Node → Answer → State → State) : List Node → State → ProbComp (State × (Cell → Answer))
+  | [], state => do
+      let table ← $ᵗ (Cell → Answer)
+      pure (state, table)
+  | node :: nodes, state => do
+      let answer ← $ᵗ Answer
+      let result ← plant input advance nodes (advance node answer state)
+      pure (result.1, Function.update result.2 (input node state) answer)
+
+theorem evalDist_table_extract {Result : Type} (cell : Cell)
+    (next : (Cell → Answer) → Answer → ProbComp Result) :
+    𝒟[do let table ← ($ᵗ (Cell → Answer) : ProbComp _); next table (table cell)] =
+      𝒟[do
+        let answer ← ($ᵗ Answer : ProbComp _)
+        let table ← ($ᵗ (Cell → Answer) : ProbComp _)
+        next (Function.update table cell answer) answer] := by
+  have h := congrArg (fun distribution : SPMF (Cell → Answer) =>
+    distribution >>= fun table => 𝒟[next table (table cell)])
+    (evalDist_uniformSample_bind_update (R := Answer) cell)
+  simpa only [evalDist_bind, bind_assoc, evalDist_pure, pure_bind, Function.update_self] using h.symm
+
+theorem evalDist_read_eq_plant (input : Node → State → Cell)
+    (advance : Node → Answer → State → State) (hsep : Separated input)
+    (nodes : List Node) (hnodes : nodes.Nodup) (state : State) :
+    𝒟[do
+      let table ← ($ᵗ (Cell → Answer) : ProbComp _)
+      pure (read input advance table nodes state, table)] =
+      𝒟[plant input advance nodes state] := by
+  induction nodes generalizing state with
+  | nil => rfl
+  | cons node nodes ih =>
+      obtain ⟨hnode, hnodes⟩ := List.nodup_cons.mp hnodes
+      simp only [read]
+      rw [evalDist_table_extract (input node state)
+        (fun table answer => pure (read input advance table nodes (advance node answer state), table))]
+      simp_rw [read_update_of_not_mem input advance hsep _ nodes node hnode]
+      change 𝒟[do
+        let answer ← ($ᵗ Answer : ProbComp _)
+        let table ← ($ᵗ (Cell → Answer) : ProbComp _)
+        pure (read input advance table nodes (advance node answer state),
+          Function.update table (input node state) answer)] = _
+      simp only [plant]
+      apply evalDist_bind_congr_left
+      intro answer
+      have h := congrArg (fun distribution : SPMF (State × (Cell → Answer)) =>
+        distribution >>= fun result => pure (result.1, Function.update result.2 (input node state) answer))
+        (ih hnodes (advance node answer state))
+      simpa only [evalDist_bind, evalDist_pure, bind_assoc, pure_bind] using h
+
+end SphincsSecurity.Concrete.FiniteGraphSampling
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierEncodingCongruence.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierEncodingCongruence.lean
new file mode 100644
index 000000000..d90e00c93
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierEncodingCongruence.lean
@@ -0,0 +1,124 @@
+import SphincsSecurity.Proof.Ots.EncodingOracleSplit
+import SphincsSecurity.Proof.Hypertree.FrontierSigningOracleCongruence
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs frontierTreeNode referenceEncodingSearch boundaryEval publicDigestLoop
+
+def AgreeOutsideEncoding (parameter : PublicParameter) (f g : QueryImpl HashSpec Id) : Prop :=
+  ∀ input, input ∉ canonicalEncodingInputs parameter → f input = g input
+
+theorem AgreeOutsideEncoding.domain {parameter : PublicParameter} {f g : QueryImpl HashSpec Id}
+    (h : AgreeOutsideEncoding parameter f g) (domain : HashDomain)
+    (htag : (hashDomainFields domain).tag ≠ 4#8) (payload : HashInput) :
+    f (tweakableHashInput parameter domain payload) = g (tweakableHashInput parameter domain payload) := by
+  apply h
+  intro hinput
+  rw [canonicalEncodingInputs] at hinput
+  simp only [Finset.mem_biUnion, Finset.mem_univ, true_and, Finset.mem_image] at hinput
+  obtain ⟨position, pair, heq⟩ := hinput
+  exact htag (FtsProbeSimulation.tweakableHashInput_tag_eq parameter domain
+    (.encoding position.lay position.tree position.leafIdx) payload _ heq.symm)
+
+namespace AgreeOutsideEncoding
+
+variable {parameter : PublicParameter} {f g : QueryImpl HashSpec Id}
+  (h : AgreeOutsideEncoding parameter f g)
+
+include h
+
+theorem frontierTreeNode (lay : Layer) (tree : TreeIndex) (words : LeafIndex → Encoding)
+    (frontier : LeafIndex → ChainIndex → Digest) (level nodeIdx : Nat) :
+    evalWithAnswerFn f (Concrete.frontierTreeNode parameter lay tree words frontier level nodeIdx) =
+      evalWithAnswerFn g (Concrete.frontierTreeNode parameter lay tree words frontier level nodeIdx) := by
+  apply eval_frontierTreeNode_congr
+  · intro leaf chainIdx step _ input
+    exact congrArg truncateHash (h.domain (.chain lay tree leaf chainIdx step) (by simp only [hashDomainFields]; decide) (digestBytes input))
+  · intro leaf payload
+    exact congrArg truncateHash (h.domain (.leaf lay tree leaf) (by simp only [hashDomainFields]; decide) payload)
+  · intro level nodeIdx payload
+    exact congrArg truncateHash (h.domain (.node lay tree level nodeIdx) (by simp only [hashDomainFields]; decide) payload)
+
+theorem frontierTreePath (lay : Layer) (tree : TreeIndex) (words : LeafIndex → Encoding)
+    (frontier : LeafIndex → ChainIndex → Digest) (leaf : LeafIndex) :
+    evalWithAnswerFn f (Concrete.frontierTreePath parameter lay tree words frontier leaf) =
+      evalWithAnswerFn g (Concrete.frontierTreePath parameter lay tree words frontier leaf) := by
+  simp only [Concrete.frontierTreePath, evalWithAnswerFn_sequenceFin]
+  funext level
+  split_ifs
+  · exact h.frontierTreeNode _ _ _ _ _ _
+  · rfl
+
+theorem ftsNode (index : Index) (tree : FtsTree) (secret : FtsLeaf → Digest) (level nodeIdx : Nat) :
+    evalWithAnswerFn f (Concrete.ftsNode parameter index tree secret level nodeIdx) =
+      evalWithAnswerFn g (Concrete.ftsNode parameter index tree secret level nodeIdx) := by
+  induction level generalizing nodeIdx with
+  | zero =>
+      simp only [ftsNode_zero_eq, ftsLeafHash, eval_tweakableHash]
+      exact congrArg truncateHash (h.domain (.ftsLeaf index tree _) (by simp only [hashDomainFields]; decide) _)
+  | succ level ih =>
+      simp only [ftsNode_succ_eq, evalWithAnswerFn_bind, ih, eval_tweakableHash]
+      exact congrArg truncateHash (h.domain (.ftsNode index tree (level + 1) nodeIdx) (by simp only [hashDomainFields]; decide) _)
+
+theorem ftsOpen (index : Index) (leaves : IndexGroup → FtsLeaf) (secret : FtsTree → FtsLeaf → Digest) :
+    evalWithAnswerFn f (Concrete.ftsOpen parameter index leaves secret) =
+      evalWithAnswerFn g (Concrete.ftsOpen parameter index leaves secret) := by
+  simp only [Concrete.ftsOpen, evalWithAnswerFn_sequenceFin, h.ftsNode]
+
+theorem publicDigestLoop (root : Digest) (message : Message) (attempts : Nat) :
+    fixedBoundaryRun parameter f (Concrete.publicDigestLoop parameter root message attempts) =
+      fixedBoundaryRun parameter g (Concrete.publicDigestLoop parameter root message attempts) := by
+  have hattempt (randomness : Randomness) :
+      boundaryEval parameter f (publicSignAttempt parameter root message randomness) =
+        boundaryEval parameter g (publicSignAttempt parameter root message randomness) := by
+    have hinput := h.domain .message (by simp only [hashDomainFields]; decide) (messageDigestPayload root message randomness)
+    simp [publicSignAttempt, messageDigest, oracleHash, boundaryEval, QueryImpl.withTrace_apply, hinput]
+  induction attempts with
+  | zero => simp only [Concrete.publicDigestLoop, fixedBoundaryRun_pure]
+  | succ attempts ih =>
+      rw [Concrete.publicDigestLoop]
+      apply fixedBoundaryRun_bind_congr
+      · exact fixedBoundaryRun_lift_prob_eq parameter f g sampleRandomness
+      · intro randomness
+        apply fixedBoundaryRun_bind_congr
+        · rw [fixedBoundaryRun_lift_hash, fixedBoundaryRun_lift_hash, hattempt]
+        · intro attempt
+          cases attempt with
+          | none => exact ih
+          | some selected => rfl
+
+theorem frontierSignLayer (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) (index : Index) (lay : Layer)
+    (hsearch : frontierLayerSearch parameter f ftsSecret words frontier index lay =
+      frontierLayerSearch parameter g ftsSecret words frontier index lay) :
+    Concrete.frontierSignLayer parameter f ftsSecret words frontier index lay =
+      Concrete.frontierSignLayer parameter g ftsSecret words frontier index lay := by
+  simp only [Concrete.frontierSignLayer, hsearch, h.frontierTreePath]
+
+theorem frontierSignAfterDigest (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (hsearch : ∀ index lay, frontierLayerSearch parameter f ftsSecret words frontier index lay =
+      frontierLayerSearch parameter g ftsSecret words frontier index lay)
+    (randomness : Randomness) (index : Index) (leaves : IndexGroup → FtsLeaf) :
+    Concrete.frontierSignAfterDigest parameter f ftsSecret words frontier randomness index leaves =
+      Concrete.frontierSignAfterDigest parameter g ftsSecret words frontier randomness index leaves := by
+  simp only [Concrete.frontierSignAfterDigest, h.frontierSignLayer ftsSecret words frontier _ _ (hsearch _ _),
+    h.ftsOpen]
+
+theorem frontierSigningRun (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (hsearch : ∀ index lay, frontierLayerSearch parameter f ftsSecret words frontier index lay =
+      frontierLayerSearch parameter g ftsSecret words frontier index lay) (message : Message) :
+    Concrete.frontierSigningRun parameter root f ftsSecret words frontier message =
+      Concrete.frontierSigningRun parameter root g ftsSecret words frontier message := by
+  simp only [Concrete.frontierSigningRun, frontierSigningRecord, h.publicDigestLoop,
+    h.frontierSignAfterDigest ftsSecret words frontier hsearch]
+
+theorem frontierRoot (words : OtsReferenceWords) (frontier : OtsFrontierValues) :
+    Concrete.frontierRoot parameter f words frontier = Concrete.frontierRoot parameter g words frontier :=
+  h.frontierTreeNode _ _ _ _ _ _
+
+end AgreeOutsideEncoding
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierGameProjection.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierGameProjection.lean
new file mode 100644
index 000000000..0b043f188
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierGameProjection.lean
@@ -0,0 +1,138 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Reference.BoundarySimulation
+import SphincsSecurity.Proof.Reference.DirectQueryBudget
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] boundaryEval frontierTreeNode
+
+theorem simulateQ_eq_fixedBoundaryRun {α : Type} (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (computation : OracleComp OracleWorld α) :
+    simulateQ ((fixedHashWorld f).withTrace (signingBoundaryTrace parameter)) computation =
+      WriterT.mk (fixedBoundaryRun parameter f computation) := rfl
+
+noncomputable def frontierAdversaryImpl (parameter : PublicParameter) (root : Digest)
+    (f : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) :
+    QueryImpl (OracleWorld + SigningSpec) (WriterT SigningBoundaryTrace ProbComp)
+  | .inl input => (fixedHashWorld f).withTrace (signingBoundaryTrace parameter) input
+  | .inr message => WriterT.mk (frontierSigningRun parameter root f ftsSecret words frontier message)
+
+theorem simulateQ_expandedAdversaryImpl_frontier (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (hfrontier : IsSigningFrontier key f words frontier)
+    (hwords : ∀ index lay, FrontierReferenceWord key.parameter f key.ftsSecret words frontier index lay)
+    (input : (OracleWorld + SigningSpec).Domain) :
+    simulateQ ((fixedHashWorld f).withTrace (signingBoundaryTrace key.parameter)) (expandedAdversaryImpl key input) =
+      frontierAdversaryImpl key.parameter key.root f key.ftsSecret words frontier input := by
+  cases input with
+  | inl input => exact simulateQ_spec_query (impl := (fixedHashWorld f).withTrace (signingBoundaryTrace key.parameter)) input
+  | inr message =>
+      rw [show expandedAdversaryImpl key (.inr message) = sign key message from rfl,
+        simulateQ_eq_fixedBoundaryRun]
+      unfold frontierAdversaryImpl
+      exact congrArg (fun result : ProbComp (Option Signature × SigningBoundaryTrace) =>
+        (WriterT.mk result : WriterT SigningBoundaryTrace ProbComp (Option Signature)))
+        (fixedBoundaryRun_sign_frontier key f words frontier hfrontier hwords message)
+
+noncomputable def frontierAdversaryRun {α : Type} (parameter : PublicParameter) (root : Digest)
+    (f : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) :
+    ProbComp ((α × QueryLog SigningSpec) × SigningBoundaryTrace) :=
+  ((simulateQ ((frontierAdversaryImpl parameter root f ftsSecret words frontier).withTraceAppend signingLogFragment)
+    computation).run).run
+
+theorem fixedBoundaryRun_adversary_frontier {α : Type} (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (hfrontier : IsSigningFrontier key f words frontier)
+    (hwords : ∀ index lay, FrontierReferenceWord key.parameter f key.ftsSecret words frontier index lay)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) :
+    fixedBoundaryRun key.parameter f
+        (simulateQ (forwardOracles + signingOracle scheme key) computation).run =
+      frontierAdversaryRun key.parameter key.root f key.ftsSecret words frontier computation := by
+  rw [forwardOracles_add_signingOracle_eq_withTraceAppend]
+  unfold fixedBoundaryRun frontierAdversaryRun
+  congr 1
+  apply simulateQ_writerAppend_compose
+  intro input
+  simp only [QueryImpl.withTraceAppend_apply]
+  simp [simulateQ_expandedAdversaryImpl_frontier key f words frontier hfrontier hwords input]
+
+noncomputable def frontierGameRest (parameter : PublicParameter) (root : Digest)
+    (f : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) (adversary : Adversary) :
+    ProbComp (Bool × SigningBoundaryTrace) := do
+  let result ← frontierAdversaryRun parameter root f ftsSecret words frontier
+    (adversary.main ⟨root, parameter⟩)
+  let checked := boundaryEval parameter f (verify ⟨root, parameter⟩ result.1.1.message result.1.1.signature)
+  pure (decide (SigningTranscript.Valid result.1.2 ∧ ¬SigningTranscript.Contains result.1.2 result.1.1) && checked.1,
+    result.2 * checked.2)
+
+theorem fixedBoundaryRun_gameRest_frontier (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (hfrontier : IsSigningFrontier key f words frontier)
+    (hwords : ∀ index lay, FrontierReferenceWord key.parameter f key.ftsSecret words frontier index lay)
+    (adversary : Adversary) :
+    fixedBoundaryRun key.parameter f (gameRest scheme adversary ⟨key.root, key.parameter⟩ key) =
+      frontierGameRest key.parameter key.root f key.ftsSecret words frontier adversary := by
+  rw [gameRest, fixedBoundaryRun_bind, fixedBoundaryRun_adversary_frontier key f words frontier hfrontier hwords]
+  unfold frontierGameRest
+  apply bind_congr
+  rintro ⟨⟨forgery, log⟩, trace⟩
+  rw [fixedBoundaryRun_bind]
+  change (fun final => (final.1, trace * final.2)) <$>
+    (fixedBoundaryRun key.parameter f (liftM (verify ⟨key.root, key.parameter⟩ forgery.message forgery.signature)) >>=
+      fun checked => (fun final => (final.1, checked.2 * final.2)) <$>
+        fixedBoundaryRun key.parameter f (pure
+          (decide (SigningTranscript.Valid log ∧ ¬SigningTranscript.Contains log forgery) && checked.1))) = _
+  rw [fixedBoundaryRun_lift_hash, pure_bind, fixedBoundaryRun_pure]
+  simp only [map_pure, mul_one]
+
+noncomputable def frontierRoot (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) : Digest :=
+  evalWithAnswerFn f (frontierTreeNode parameter topLayer rootTree (words topLayer rootTree)
+    (frontier topLayer rootTree) (layerHeight topLayer) 0)
+
+theorem frontierRoot_eq (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (hfrontier : IsSigningFrontier key f words frontier) :
+    frontierRoot key.parameter f words frontier =
+      evalWithAnswerFn f (treeRoot key.parameter topLayer rootTree (key.otsSecret topLayer rootTree)) :=
+  eval_frontierTreeNode key.parameter f topLayer rootTree (key.otsSecret topLayer rootTree)
+    (words topLayer rootTree) (frontier topLayer rootTree) (hfrontier topLayer rootTree) _ _
+
+noncomputable def frontierGame (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords)
+    (frontier : OtsFrontierValues) (adversary : Adversary) : ProbComp (Bool × SigningBoundaryTrace) :=
+  (fun result => (result.1, (FreeMonoid.of none) ^ 1212415 * result.2)) <$>
+    frontierGameRest parameter (frontierRoot parameter f words frontier) f ftsSecret words frontier adversary
+
+theorem fixedBoundaryRun_gameAfterSecrets_canonical (adversary : Adversary) (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (f : QueryImpl HashSpec Id) (dummy : OtsReferenceWords) :
+    let root := evalWithAnswerFn f (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))
+    let key : SecretKey := ⟨parameter, root, otsSecret, ftsSecret⟩
+    let words := canonicalReferenceWords key f dummy
+    fixedBoundaryRun parameter f (gameAfterSecrets adversary parameter otsSecret ftsSecret) =
+      frontierGame parameter f ftsSecret words (canonicalFrontierValues key f words) adversary := by
+  dsimp only
+  let root := evalWithAnswerFn f (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))
+  let key : SecretKey := ⟨parameter, root, otsSecret, ftsSecret⟩
+  let words := canonicalReferenceWords key f dummy
+  let frontier := canonicalFrontierValues key f words
+  have hfrontier := isSigningFrontier_canonical key f words
+  change fixedBoundaryRun parameter f (gameAfterSecrets adversary parameter otsSecret ftsSecret) =
+    frontierGame parameter f ftsSecret words frontier adversary
+  have hroot := frontierRoot_eq key f words frontier hfrontier
+  change frontierRoot parameter f words frontier = root at hroot
+  rw [gameAfterSecrets, fixedBoundaryRun_bind, fixedBoundaryRun_lift_hash]
+  have htree : boundaryEval parameter f (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree)) =
+      (root, (FreeMonoid.of none) ^ 1212415) := by
+    exact boundaryEval_treeNode parameter f topLayer rootTree (otsSecret topLayer rootTree) _ _
+  rw [htree, pure_bind, fixedBoundaryRun_gameRest_frontier key f words frontier hfrontier
+    (frontierReferenceWord_canonical key f dummy)]
+  rw [frontierGame, hroot]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierOracleCongruence.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierOracleCongruence.lean
new file mode 100644
index 000000000..c86db2bce
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierOracleCongruence.lean
@@ -0,0 +1,112 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.FrontierGameProjection
+import SphincsSecurity.Proof.Hypertree.FrontierOracleMask
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] frontierTreeNode referenceEncodingSearch boundaryEval
+
+variable (parameter : PublicParameter) (words : OtsReferenceWords)
+  (f g : QueryImpl HashSpec Id) (h : AgreeOutsideOtsPrefixes parameter words f g)
+
+include h
+
+theorem eval_frontierTreeNode_eq_of_agree (lay : Layer) (tree : TreeIndex)
+    (frontier : LeafIndex → ChainIndex → Digest) (level nodeIdx : Nat) :
+    evalWithAnswerFn f (frontierTreeNode parameter lay tree (words lay tree) frontier level nodeIdx) =
+      evalWithAnswerFn g (frontierTreeNode parameter lay tree (words lay tree) frontier level nodeIdx) := by
+  apply eval_frontierTreeNode_congr
+  · intro leaf chainIdx step hstep input
+    exact congrArg truncateHash (h.chain lay tree leaf chainIdx step hstep (digestBytes input))
+  · intro leaf payload
+    exact congrArg truncateHash (h.other (.leaf lay tree leaf) (by simp only [hashDomainFields]; decide) payload)
+  · intro level nodeIdx payload
+    exact congrArg truncateHash (h.other (.node lay tree level nodeIdx) (by simp only [hashDomainFields]; decide) payload)
+
+theorem eval_frontierTreePath_eq_of_agree (lay : Layer) (tree : TreeIndex)
+    (frontier : LeafIndex → ChainIndex → Digest) (leaf : LeafIndex) :
+    evalWithAnswerFn f (frontierTreePath parameter lay tree (words lay tree) frontier leaf) =
+      evalWithAnswerFn g (frontierTreePath parameter lay tree (words lay tree) frontier leaf) := by
+  simp only [frontierTreePath, evalWithAnswerFn_sequenceFin]
+  funext level
+  split_ifs
+  · exact eval_frontierTreeNode_eq_of_agree parameter words f g h lay tree frontier _ _
+  · rfl
+
+theorem eval_ftsNode_eq_of_agree (index : Index) (tree : FtsTree) (secret : FtsLeaf → Digest)
+    (level nodeIdx : Nat) :
+    evalWithAnswerFn f (ftsNode parameter index tree secret level nodeIdx) =
+      evalWithAnswerFn g (ftsNode parameter index tree secret level nodeIdx) := by
+  induction level generalizing nodeIdx with
+  | zero =>
+      simp only [ftsNode_zero_eq, ftsLeafHash, eval_tweakableHash]
+      exact congrArg truncateHash (h.other (.ftsLeaf index tree _) (by simp only [hashDomainFields]; decide) _)
+  | succ level ih =>
+      simp only [ftsNode_succ_eq, evalWithAnswerFn_bind, ih, eval_tweakableHash]
+      exact congrArg truncateHash (h.other (.ftsNode index tree (level + 1) nodeIdx) (by simp only [hashDomainFields]; decide) _)
+
+theorem eval_ftsKey_eq_of_agree (index : Index) (secret : FtsTree → FtsLeaf → Digest) :
+    evalWithAnswerFn f (ftsKey parameter index secret) = evalWithAnswerFn g (ftsKey parameter index secret) := by
+  simp only [ftsKey, evalWithAnswerFn_bind, evalWithAnswerFn_sequenceFin,
+    eval_ftsNode_eq_of_agree parameter words f g h, eval_tweakableHash]
+  exact congrArg truncateHash (h.other (.ftsRoots index) (by simp only [hashDomainFields]; decide) _)
+
+theorem eval_ftsOpen_eq_of_agree (index : Index) (leaves : IndexGroup → FtsLeaf)
+    (secret : FtsTree → FtsLeaf → Digest) :
+    evalWithAnswerFn f (ftsOpen parameter index leaves secret) =
+      evalWithAnswerFn g (ftsOpen parameter index leaves secret) := by
+  simp only [ftsOpen, evalWithAnswerFn_sequenceFin, eval_ftsNode_eq_of_agree parameter words f g h]
+
+theorem eval_frontierLayerMessage_eq_of_agree (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (frontier : OtsFrontierValues) (index : Index) (lay : Layer) :
+    evalWithAnswerFn f (frontierLayerMessage parameter ftsSecret words frontier index lay) =
+      evalWithAnswerFn g (frontierLayerMessage parameter ftsSecret words frontier index lay) := by
+  unfold frontierLayerMessage
+  split_ifs
+  · exact eval_frontierTreeNode_eq_of_agree parameter words f g h _ _ _ _ _
+  · exact eval_ftsKey_eq_of_agree parameter words f g h _ _
+
+theorem eval_encode_eq_of_agree (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex)
+    (message : Digest) (counter : Counter) :
+    evalWithAnswerFn f (encode parameter lay tree leaf message counter) =
+      evalWithAnswerFn g (encode parameter lay tree leaf message counter) := by
+  simp only [encode, evalWithAnswerFn_bind, evalWithAnswerFn_pure, eval_tweakableHash,
+    h.other (.encoding lay tree leaf) (by simp only [hashDomainFields]; decide)]
+
+theorem referenceEncodingSearch_eq_of_agree (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex)
+    (message : Digest) (attempts start : Nat) :
+    referenceEncodingSearch parameter f lay tree leaf message attempts start =
+      referenceEncodingSearch parameter g lay tree leaf message attempts start := by
+  induction attempts generalizing start with
+  | zero => simp only [referenceEncodingSearch]
+  | succ attempts ih =>
+      simp only [referenceEncodingSearch, eval_encode_eq_of_agree parameter words f g h, ih]
+
+theorem frontierLayerSearch_eq_of_agree (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (frontier : OtsFrontierValues) (index : Index) (lay : Layer) :
+    frontierLayerSearch parameter f ftsSecret words frontier index lay =
+      frontierLayerSearch parameter g ftsSecret words frontier index lay := by
+  rw [frontierLayerSearch, frontierLayerSearch,
+    eval_frontierLayerMessage_eq_of_agree parameter words f g h,
+    referenceEncodingSearch_eq_of_agree parameter words f g h]
+
+theorem frontierSignLayer_eq_of_agree (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (frontier : OtsFrontierValues) (index : Index) (lay : Layer) :
+    frontierSignLayer parameter f ftsSecret words frontier index lay =
+      frontierSignLayer parameter g ftsSecret words frontier index lay := by
+  simp only [frontierSignLayer, frontierLayerSearch_eq_of_agree parameter words f g h,
+    eval_frontierTreePath_eq_of_agree parameter words f g h]
+
+theorem frontierSignAfterDigest_eq_of_agree (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (frontier : OtsFrontierValues) (randomness : Randomness) (index : Index) (leaves : IndexGroup → FtsLeaf) :
+    frontierSignAfterDigest parameter f ftsSecret words frontier randomness index leaves =
+      frontierSignAfterDigest parameter g ftsSecret words frontier randomness index leaves := by
+  simp only [frontierSignAfterDigest, frontierSignLayer_eq_of_agree parameter words f g h,
+    eval_ftsOpen_eq_of_agree parameter words f g h]
+
+theorem frontierRoot_eq_of_agree (frontier : OtsFrontierValues) :
+    frontierRoot parameter f words frontier = frontierRoot parameter g words frontier :=
+  eval_frontierTreeNode_eq_of_agree parameter words f g h _ _ _ _ _
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierOracleMask.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierOracleMask.lean
new file mode 100644
index 000000000..08bace8d9
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierOracleMask.lean
@@ -0,0 +1,75 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.FrontierSignerErasure
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+def PrivateOtsPrefixInput (parameter : PublicParameter) (words : OtsReferenceWords) (input : HashInput) : Prop :=
+  ∃ lay tree leaf chainIdx step,
+    step.val < (words lay tree leaf chainIdx).val ∧
+      AtPosition parameter input (.chain lay tree leaf chainIdx step)
+
+theorem privateOtsPrefixInput_chain_iff (parameter : PublicParameter) (words : OtsReferenceWords)
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (chainIdx : ChainIndex) (step : ChainStep)
+    (payload : HashInput) :
+    PrivateOtsPrefixInput parameter words
+        (tweakableHashInput parameter (.chain lay tree leaf chainIdx step) payload) ↔
+      step.val < (words lay tree leaf chainIdx).val := by
+  constructor
+  · rintro ⟨otherLay, otherTree, otherLeaf, otherChain, otherStep, hlt, hat⟩
+    have heq := atPosition_unique parameter
+      (show AtPosition parameter (tweakableHashInput parameter (.chain lay tree leaf chainIdx step) payload)
+        (.chain lay tree leaf chainIdx step) from ⟨payload, rfl⟩) hat
+    simp only [Position.chain.injEq] at heq
+    obtain ⟨rfl, rfl, rfl, rfl, rfl⟩ := heq
+    exact hlt
+  · intro hlt
+    exact ⟨lay, tree, leaf, chainIdx, step, hlt, payload, rfl⟩
+
+theorem not_privateOtsPrefixInput_of_tag (parameter : PublicParameter) (words : OtsReferenceWords)
+    (domain : HashDomain) (htag : (hashDomainFields domain).tag ≠ 1#8) (payload : HashInput) :
+    ¬ PrivateOtsPrefixInput parameter words (tweakableHashInput parameter domain payload) := by
+  rintro ⟨lay, tree, leaf, chainIdx, step, _, prefixPayload, heq⟩
+  exact htag (FtsProbeSimulation.tweakableHashInput_tag_eq parameter domain
+    (.chain lay tree leaf chainIdx step) payload prefixPayload heq)
+
+def AgreeOutsideOtsPrefixes (parameter : PublicParameter) (words : OtsReferenceWords)
+    (f g : QueryImpl HashSpec Id) : Prop :=
+  ∀ input, ¬ PrivateOtsPrefixInput parameter words input → f input = g input
+
+theorem AgreeOutsideOtsPrefixes.chain {parameter : PublicParameter} {words : OtsReferenceWords}
+    {f g : QueryImpl HashSpec Id} (h : AgreeOutsideOtsPrefixes parameter words f g)
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (chainIdx : ChainIndex) (step : ChainStep)
+    (hstep : (words lay tree leaf chainIdx).val ≤ step.val) (payload : HashInput) :
+    f (tweakableHashInput parameter (.chain lay tree leaf chainIdx step) payload) =
+      g (tweakableHashInput parameter (.chain lay tree leaf chainIdx step) payload) := by
+  apply h
+  rw [privateOtsPrefixInput_chain_iff]
+  exact not_lt_of_ge hstep
+
+theorem AgreeOutsideOtsPrefixes.other {parameter : PublicParameter} {words : OtsReferenceWords}
+    {f g : QueryImpl HashSpec Id} (h : AgreeOutsideOtsPrefixes parameter words f g)
+    (domain : HashDomain) (htag : (hashDomainFields domain).tag ≠ 1#8) (payload : HashInput) :
+    f (tweakableHashInput parameter domain payload) = g (tweakableHashInput parameter domain payload) :=
+  h _ (not_privateOtsPrefixInput_of_tag parameter words domain htag payload)
+
+noncomputable def maskOtsPrefixes (parameter : PublicParameter) (words : OtsReferenceWords)
+    (f : QueryImpl HashSpec Id) : QueryImpl HashSpec Id :=
+  fun input => if PrivateOtsPrefixInput parameter words input then 0 else f input
+
+theorem maskOtsPrefixes_agrees (parameter : PublicParameter) (words : OtsReferenceWords)
+    (f : QueryImpl HashSpec Id) : AgreeOutsideOtsPrefixes parameter words f (maskOtsPrefixes parameter words f) := by
+  intro input hinput
+  simp only [maskOtsPrefixes, if_neg hinput]
+
+theorem maskOtsPrefixes_congr {parameter : PublicParameter} {words : OtsReferenceWords}
+    {f g : QueryImpl HashSpec Id} (h : AgreeOutsideOtsPrefixes parameter words f g) :
+    maskOtsPrefixes parameter words f = maskOtsPrefixes parameter words g := by
+  funext input
+  by_cases hinput : PrivateOtsPrefixInput parameter words input
+  · simp only [maskOtsPrefixes, if_pos hinput]
+  · simp only [maskOtsPrefixes, if_neg hinput, h input hinput]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierRandomOracle.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierRandomOracle.lean
new file mode 100644
index 000000000..2eaad4762
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierRandomOracle.lean
@@ -0,0 +1,110 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Reference.FiniteHashWorld
+import SphincsSecurity.Proof.Hypertree.FrontierGameProjection
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec OracleComp.DeferredSampling
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] hashInputs boundaryEval fixedBoundaryRun
+
+theorem simulateQ_fixedHashWorld_lift_prob {α : Type} (f : QueryImpl HashSpec Id) (computation : ProbComp α) :
+    simulateQ (fixedHashWorld f) (liftM computation) = computation := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => simp
+  | query_bind input next ih =>
+      rw [liftM_bind, simulateQ_bind]
+      have hquery : simulateQ (fixedHashWorld f)
+          (liftM (liftM (unifSpec.query input) : ProbComp _)) = (liftM (unifSpec.query input) : ProbComp _) := by
+        change simulateQ (fixedHashWorld f) (liftM (OracleWorld.query (.inl input))) = _
+        rw [simulateQ_spec_query]
+        rfl
+      rw [hquery]
+      exact bind_congr ih
+
+noncomputable def boundaryGameCore (adversary : Adversary) : OracleComp OracleWorld (Bool × SigningBoundaryTrace) := do
+  let parameter ← liftM sampleParameter
+  let otsSecret ← liftM sampleOtsSecrets
+  let ftsSecret ← liftM sampleFtsSecrets
+  boundaryComputation parameter (gameAfterSecrets adversary parameter otsSecret ftsSecret)
+
+theorem boundaryComputation_fst {α : Type} (parameter : PublicParameter) (computation : OracleComp OracleWorld α) :
+    Prod.fst <$> boundaryComputation parameter computation = computation := by
+  rw [boundaryComputation, QueryImpl.fst_map_run_withTrace, simulateQ_id']
+
+theorem boundaryGameCore_fst (adversary : Adversary) :
+    Prod.fst <$> boundaryGameCore adversary = gameCore scheme adversary := by
+  rw [gameCore_eq_secrets, boundaryGameCore]
+  simp only [map_bind, boundaryComputation_fst]
+
+noncomputable def fixedFrontierGame (f : QueryImpl HashSpec Id) (dummy : OtsReferenceWords)
+    (adversary : Adversary) : ProbComp (Bool × SigningBoundaryTrace) := do
+  let parameter ← sampleParameter
+  let otsSecret ← sampleOtsSecrets
+  let ftsSecret ← sampleFtsSecrets
+  let root := evalWithAnswerFn f (treeRoot parameter topLayer rootTree (otsSecret topLayer rootTree))
+  let key : SecretKey := ⟨parameter, root, otsSecret, ftsSecret⟩
+  let words := canonicalReferenceWords key f dummy
+  frontierGame parameter f ftsSecret words (canonicalFrontierValues key f words) adversary
+
+theorem simulateQ_boundaryGameCore_frontier (f : QueryImpl HashSpec Id) (dummy : OtsReferenceWords)
+    (adversary : Adversary) :
+    simulateQ (fixedHashWorld f) (boundaryGameCore adversary) = fixedFrontierGame f dummy adversary := by
+  rw [boundaryGameCore, fixedFrontierGame]
+  simp only [simulateQ_bind, simulateQ_fixedHashWorld_lift_prob]
+  apply bind_congr
+  intro parameter
+  apply bind_congr
+  intro otsSecret
+  apply bind_congr
+  intro ftsSecret
+  rw [← fixedBoundaryRun_eq_boundaryComputation, fixedBoundaryRun_gameAfterSecrets_canonical]
+
+noncomputable def frontierOracleGame (inputs : Finset HashInput) (dummy : OtsReferenceWords)
+    (adversary : Adversary) : ProbComp (Bool × SigningBoundaryTrace) := do
+  let table ← sampleHashTable inputs
+  fixedFrontierGame (finiteHashAnswer ∅ inputs table) dummy adversary
+
+theorem evalDist_boundaryGameCore_frontier (inputs : Finset HashInput) (dummy : OtsReferenceWords)
+    (adversary : Adversary) (hinputs : hashInputs (boundaryGameCore adversary) ⊆ inputs) :
+    𝒟[(simulateQ romImpl (boundaryGameCore adversary)).run' ∅] =
+      𝒟[frontierOracleGame inputs dummy adversary] := by
+  rw [evalDist_romRun_eq_finiteHash _ inputs hinputs ∅, frontierOracleGame]
+  apply evalDist_bind_congr_left
+  intro table
+  rw [simulateQ_boundaryGameCore_frontier _ dummy adversary]
+
+theorem evalDist_gameCore_frontier (inputs : Finset HashInput) (dummy : OtsReferenceWords)
+    (adversary : Adversary) (hinputs : hashInputs (boundaryGameCore adversary) ⊆ inputs) :
+    𝒟[(simulateQ romImpl (gameCore scheme adversary)).run' ∅] =
+      𝒟[Prod.fst <$> frontierOracleGame inputs dummy adversary] := by
+  rw [← boundaryGameCore_fst, simulateQ_map, StateT.run'_eq, StateT.run_map]
+  simp only [← LawfulFunctor.comp_map, Function.comp_def]
+  rw [evalDist_map]
+  have h := congrArg (fun distribution : SPMF (Bool × SigningBoundaryTrace) => Prod.fst <$> distribution)
+    (evalDist_boundaryGameCore_frontier inputs dummy adversary hinputs)
+  simpa only [StateT.run'_eq, evalDist_map, ← LawfulFunctor.comp_map, Function.comp_def] using h
+
+theorem boundaryRun_hashCalls_le {α : Type} (parameter : PublicParameter)
+    (computation : OracleComp OracleWorld α) (q : Nat) (hbound : computation.IsQueryBoundP (· matches .inr _) q)
+    (cache : QueryCache HashSpec) (result : (α × SigningBoundaryTrace) × QueryCache HashSpec)
+    (hresult : result ∈ support (boundaryRun parameter computation cache)) : result.1.2.hashCalls ≤ q := by
+  have h := boundaryRun_bind_query_bound parameter computation (pure : α → OracleComp OracleWorld α) q
+    (by rw [bind_pure]; exact hbound) cache result hresult
+  exact h.1
+
+theorem boundaryGameCore_hashCalls_le (adversary : Adversary) (q : Nat)
+    (hbound : HasHashQueryBound scheme adversary q) (result : Bool × SigningBoundaryTrace)
+    (hresult : result ∈ support ((simulateQ romImpl (boundaryGameCore adversary)).run' ∅)) :
+    result.2.hashCalls ≤ q := by
+  rw [boundaryGameCore, simulateQ_romImpl_liftM_bind_run', mem_support_bind_iff] at hresult
+  obtain ⟨parameter, hparameter, hresult⟩ := hresult
+  rw [simulateQ_romImpl_liftM_bind_run', mem_support_bind_iff] at hresult
+  obtain ⟨otsSecret, hots, hresult⟩ := hresult
+  rw [simulateQ_romImpl_liftM_bind_run', mem_support_bind_iff] at hresult
+  obtain ⟨ftsSecret, hfts, hresult⟩ := hresult
+  rw [← boundaryRun_fst_eq_boundaryComputation, support_map] at hresult
+  obtain ⟨record, hrecord, rfl⟩ := hresult
+  exact boundaryRun_hashCalls_le parameter _ q
+    (isQueryBoundP_gameAfterSecrets adversary q hbound hparameter hots hfts) ∅ record hrecord
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierSignerErasure.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierSignerErasure.lean
new file mode 100644
index 000000000..947c43dcb
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierSignerErasure.lean
@@ -0,0 +1,151 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.FrontierSigningEvaluation
+import SphincsSecurity.Proof.Hypertree.FrontierTreeEvaluation
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] boundaryEval sequenceFin chainWalk referenceEncodingSearch signLayer
+
+abbrev OtsReferenceWords := Layer → TreeIndex → LeafIndex → Encoding
+abbrev OtsFrontierValues := Layer → TreeIndex → LeafIndex → ChainIndex → Digest
+
+def IsSigningFrontier (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) : Prop :=
+  ∀ lay tree, IsOtsFrontier key.parameter f lay tree (key.otsSecret lay tree) (words lay tree) (frontier lay tree)
+
+def frontierLayerMessage (parameter : PublicParameter) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) (index : Index) (lay : Layer) :
+    OracleComp HashSpec Digest :=
+  if hbelow : lay.val + 1 < numLayers then
+    let below : Layer := ⟨lay.val + 1, hbelow⟩
+    frontierTreeNode parameter below (treeIndexAt index below)
+      (words below (treeIndexAt index below)) (frontier below (treeIndexAt index below)) (layerHeight below) 0
+  else ftsKey parameter index (ftsSecret index)
+
+def frontierLayerSearch (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords)
+    (frontier : OtsFrontierValues) (index : Index) (lay : Layer) : Option (Counter × Encoding) × Nat :=
+  referenceEncodingSearch parameter f lay (treeIndexAt index lay) (leafIndexAt index lay)
+    (evalWithAnswerFn f (frontierLayerMessage parameter ftsSecret words frontier index lay)) encodingAttemptLimit 0
+
+def FrontierReferenceWord (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords)
+    (frontier : OtsFrontierValues) (index : Index) (lay : Layer) : Prop :=
+  ∀ counter word, (frontierLayerSearch parameter f ftsSecret words frontier index lay).1 = some (counter, word) →
+    word = words lay (treeIndexAt index lay) (leafIndexAt index lay)
+
+def frontierSignLayer (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords)
+    (frontier : OtsFrontierValues) (index : Index) (lay : Layer) : Option LayerPart × Nat :=
+  let search := frontierLayerSearch parameter f ftsSecret words frontier index lay
+  let cost := layerMessageHashCost lay + search.2
+  match search.1 with
+  | none => (none, cost)
+  | some (counter, _) =>
+      (some (counter, frontier lay (treeIndexAt index lay) (leafIndexAt index lay),
+        evalWithAnswerFn f (frontierTreePath parameter lay (treeIndexAt index lay)
+          (words lay (treeIndexAt index lay)) (frontier lay (treeIndexAt index lay)) (leafIndexAt index lay))),
+        cost + 191 + authenticationHashCost lay)
+
+theorem eval_frontierLayerMessage (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (hfrontier : IsSigningFrontier key f words frontier) (index : Index) (lay : Layer) :
+    evalWithAnswerFn f (frontierLayerMessage key.parameter key.ftsSecret words frontier index lay) =
+      evalWithAnswerFn f (layerMessage key index lay) := by
+  unfold frontierLayerMessage layerMessage
+  split_ifs
+  · rw [treeRoot]
+    exact eval_frontierTreeNode _ _ _ _ _ _ _ (hfrontier _ _) _ _
+  · rfl
+
+theorem boundaryEval_signLayer_frontier (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (hfrontier : IsSigningFrontier key f words frontier) (index : Index) (lay : Layer)
+    (hword : FrontierReferenceWord key.parameter f key.ftsSecret words frontier index lay) :
+    boundaryEval key.parameter f (signLayer key index lay) =
+      ((frontierSignLayer key.parameter f key.ftsSecret words frontier index lay).1,
+        (FreeMonoid.of none) ^ (frontierSignLayer key.parameter f key.ftsSecret words frontier index lay).2) := by
+  let search := frontierLayerSearch key.parameter f key.ftsSecret words frontier index lay
+  let values := frontier lay (treeIndexAt index lay) (leafIndexAt index lay)
+  let message := evalWithAnswerFn f (frontierLayerMessage key.parameter key.ftsSecret words frontier index lay)
+  have hm : evalWithAnswerFn f (layerMessage key index lay) = message :=
+    (eval_frontierLayerMessage key f words frontier hfrontier index lay).symm
+  have hots : boundaryEval key.parameter f
+      (otsSign key.parameter lay (treeIndexAt index lay) (leafIndexAt index lay)
+        (key.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) message) =
+      (search.1.map (fun selected => (selected.1, values)),
+        (FreeMonoid.of none) ^ (search.2 + if search.1.isSome then 191 else 0)) := by
+    apply boundaryEval_otsSignFrom_frontier
+    intro counter word hw chainIdx
+    rw [hword counter word hw]
+    exact hfrontier _ _ _ _
+  have hotsValue := congrArg Prod.fst hots
+  rw [boundaryEval_fst] at hotsValue
+  have hpath := (eval_frontierTreePath key.parameter f lay (treeIndexAt index lay)
+    (key.otsSecret lay (treeIndexAt index lay)) (words lay (treeIndexAt index lay))
+    (frontier lay (treeIndexAt index lay)) (hfrontier _ _) (leafIndexAt index lay)).symm
+  simp only [signLayer, boundaryEval_bind, boundaryEval_layerMessage, hm, hots, hotsValue]
+  change _ = ((match search.1 with
+    | none => (none, layerMessageHashCost lay + search.2)
+    | some (counter, _) => (some (counter, values,
+        evalWithAnswerFn f (frontierTreePath key.parameter lay (treeIndexAt index lay)
+          (words lay (treeIndexAt index lay)) (frontier lay (treeIndexAt index lay)) (leafIndexAt index lay))),
+        layerMessageHashCost lay + search.2 + 191 + authenticationHashCost lay)).1,
+      (FreeMonoid.of none) ^ (frontierSignLayer key.parameter f key.ftsSecret words frontier index lay).2)
+  cases hs : search.1 with
+  | none =>
+      change (frontierLayerSearch key.parameter f key.ftsSecret words frontier index lay).1 = none at hs
+      simp only [Option.map_none, Option.isSome_none, Bool.false_eq_true, ↓reduceIte, Nat.add_zero,
+        boundaryEval_pure, frontierSignLayer, search, hs, mul_one, pow_add]
+  | some selected =>
+      obtain ⟨counter, word⟩ := selected
+      change (frontierLayerSearch key.parameter f key.ftsSecret words frontier index lay).1 = some (counter, word) at hs
+      simp only [Option.map_some, Option.isSome_some, ↓reduceIte, boundaryEval_bind,
+        boundaryEval_treePath, boundaryEval_pure, hpath, mul_one, frontierSignLayer,
+        search, hs, pow_add, mul_assoc]
+
+def frontierSignAfterDigest (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords)
+    (frontier : OtsFrontierValues) (randomness : Randomness) (index : Index) (leaves : IndexGroup → FtsLeaf) :
+    Option Signature × Nat :=
+  let layers := fun lay => frontierSignLayer parameter f ftsSecret words frontier index lay
+  let paths := evalWithAnswerFn f (ftsOpen parameter index leaves (ftsSecret index))
+  ((sequenceFin (m := Option) (fun lay => (layers lay).1)).map (fun parts =>
+      { randomness := randomness
+        ftsSecret := fun tree => ftsSecret index tree (leaves (ftsIndexOf tree))
+        ftsPath := paths
+        counter := fun lay => (parts lay).1
+        chainValue := fun lay => (parts lay).2.1
+        authPath := flattenPaths fun lay => (parts lay).2.2 }),
+    28504 + ∑ lay, (layers lay).2)
+
+theorem boundaryEval_signAfterDigest_frontier (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (hfrontier : IsSigningFrontier key f words frontier) (randomness : Randomness) (index : Index)
+    (leaves : IndexGroup → FtsLeaf)
+    (hwords : ∀ lay, FrontierReferenceWord key.parameter f key.ftsSecret words frontier index lay) :
+    boundaryEval key.parameter f (signAfterDigest key randomness index leaves) =
+      ((frontierSignAfterDigest key.parameter f key.ftsSecret words frontier randomness index leaves).1,
+        (FreeMonoid.of none) ^
+          (frontierSignAfterDigest key.parameter f key.ftsSecret words frontier randomness index leaves).2) := by
+  have hparts : (fun lay => evalWithAnswerFn f (signLayer key index lay)) =
+      (fun lay => (frontierSignLayer key.parameter f key.ftsSecret words frontier index lay).1) := by
+    funext lay
+    rw [← boundaryEval_fst key.parameter f]
+    exact congrArg Prod.fst (boundaryEval_signLayer_frontier key f words frontier hfrontier index lay (hwords lay))
+  have hlayers := boundaryEval_sequenceFin key.parameter f (fun lay => signLayer key index lay)
+    (fun lay => (frontierSignLayer key.parameter f key.ftsSecret words frontier index lay).2)
+    (fun lay => congrArg Prod.snd
+      (boundaryEval_signLayer_frontier key f words frontier hfrontier index lay (hwords lay)))
+  rw [hparts] at hlayers
+  have hlayersValue := congrArg Prod.fst hlayers
+  rw [boundaryEval_fst] at hlayersValue
+  simp only [signAfterDigest, frontierSignAfterDigest, boundaryEval_bind, boundaryEval_ftsOpen,
+    hlayers, hlayersValue]
+  cases hc : sequenceFin (m := Option) (fun lay =>
+      (frontierSignLayer key.parameter f key.ftsSecret words frontier index lay).1) with
+  | none => simp only [boundaryEval_pure, Option.map_none, mul_one, pow_add]
+  | some parts => simp only [boundaryEval_pure, Option.map_some, mul_one, pow_add]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierSigningEvaluation.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierSigningEvaluation.lean
new file mode 100644
index 000000000..eeaf82895
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierSigningEvaluation.lean
@@ -0,0 +1,88 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Reference.BoundaryHashEvaluation
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] boundaryEval sequenceFin chainWalk
+
+def referenceEncodingSearch (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (message : Digest) :
+    Nat → Nat → Option (Counter × Encoding) × Nat
+  | 0, _ => (none, 0)
+  | attempts + 1, counter =>
+      match evalWithAnswerFn f (encode parameter lay tree leaf message (BitVec.ofNat counterBits counter)) with
+      | some word => (some (BitVec.ofNat counterBits counter, word), 1)
+      | none =>
+          let rest := referenceEncodingSearch parameter f lay tree leaf message attempts (counter + 1)
+          (rest.1, 1 + rest.2)
+
+theorem boundaryEval_encode (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (message : Digest) (counter : Counter) :
+    boundaryEval parameter f (encode parameter lay tree leaf message counter) =
+      (evalWithAnswerFn f (encode parameter lay tree leaf message counter), FreeMonoid.of none) := by
+  apply boundaryEval_eq_of_snd
+  rw [encode, boundaryEval_bind,
+    boundaryEval_tweakableHash _ _ _ _ (by simp [hashDomainFields]), boundaryEval_pure, mul_one]
+
+theorem boundaryEval_otsValues (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (secret : ChainIndex → Digest)
+    (word : Encoding) (hvalid : TargetSum.Valid word) :
+    boundaryEval parameter f (sequenceFin fun chainIdx =>
+      chainWalk parameter lay tree leaf chainIdx 0 (word chainIdx).val (secret chainIdx)) =
+      (fun chainIdx => evalWithAnswerFn f
+        (chainWalk parameter lay tree leaf chainIdx 0 (word chainIdx).val (secret chainIdx)),
+        (FreeMonoid.of none) ^ 191) := by
+  have h := boundaryEval_sequenceFin parameter f
+    (fun chainIdx => chainWalk parameter lay tree leaf chainIdx 0 (word chainIdx).val (secret chainIdx))
+    (fun chainIdx => (word chainIdx).val) (fun chainIdx => by
+      apply congrArg Prod.snd (boundaryEval_chainWalk _ _ _ _ _ _ _ _ _ ?_)
+      have hdigit := (word chainIdx).isLt
+      simp only [chainLength, winternitzBits] at hdigit ⊢
+      omega)
+  change (∑ chainIdx, (word chainIdx).val) = 191 at hvalid
+  simpa only [hvalid] using h
+
+theorem boundaryEval_otsSignFrom_frontier (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (secret frontier : ChainIndex → Digest)
+    (message : Digest) (attempts counter : Nat)
+    (hfrontier : ∀ c word,
+      (referenceEncodingSearch parameter f lay tree leaf message attempts counter).1 = some (c, word) →
+      ∀ chainIdx, evalWithAnswerFn f
+        (chainWalk parameter lay tree leaf chainIdx 0 (word chainIdx).val (secret chainIdx)) = frontier chainIdx) :
+    boundaryEval parameter f (otsSignFrom parameter lay tree leaf secret message attempts counter) =
+      ((referenceEncodingSearch parameter f lay tree leaf message attempts counter).1.map
+          (fun result => (result.1, frontier)),
+        (FreeMonoid.of none) ^ ((referenceEncodingSearch parameter f lay tree leaf message attempts counter).2 +
+          if (referenceEncodingSearch parameter f lay tree leaf message attempts counter).1.isSome then 191 else 0)) := by
+  induction attempts generalizing counter with
+  | zero => simp [otsSignFrom, referenceEncodingSearch]
+  | succ attempts ih =>
+      rw [otsSignFrom, boundaryEval_bind, boundaryEval_encode]
+      cases hencode : evalWithAnswerFn f
+          (encode parameter lay tree leaf message (BitVec.ofNat counterBits counter)) with
+      | none =>
+          have ht : ∀ c word,
+              (referenceEncodingSearch parameter f lay tree leaf message attempts (counter + 1)).1 = some (c, word) →
+              ∀ chainIdx, evalWithAnswerFn f
+                (chainWalk parameter lay tree leaf chainIdx 0 (word chainIdx).val (secret chainIdx)) = frontier chainIdx := by
+            intro c word hw
+            apply hfrontier c word
+            simpa only [referenceEncodingSearch, hencode] using hw
+          rw [ih (counter + 1) ht]
+          simp only [referenceEncodingSearch, hencode, Nat.add_assoc, pow_add, pow_one]
+      | some word =>
+          have hvalid : TargetSum.Valid word := by
+            apply TargetSum.valid_of_decodeDigest_eq_some
+            simpa only [encode, evalWithAnswerFn_bind, evalWithAnswerFn_pure] using hencode
+          have hv : (fun chainIdx => evalWithAnswerFn f
+              (chainWalk parameter lay tree leaf chainIdx 0 (word chainIdx).val (secret chainIdx))) = frontier := by
+            funext chainIdx
+            exact hfrontier (BitVec.ofNat counterBits counter) word
+              (by simp only [referenceEncodingSearch, hencode]) chainIdx
+          rw [boundaryEval_bind, boundaryEval_otsValues _ _ _ _ _ _ _ hvalid]
+          simp only [boundaryEval_pure, evalWithAnswerFn_sequenceFin, hv, mul_one,
+            referenceEncodingSearch, hencode, Option.map_some, Option.isSome_some, ↓reduceIte]
+          rw [← pow_succ']
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierSigningOracleCongruence.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierSigningOracleCongruence.lean
new file mode 100644
index 000000000..e72693263
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierSigningOracleCongruence.lean
@@ -0,0 +1,74 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.FrontierOracleCongruence
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] boundaryEval publicDigestLoop
+
+theorem fixedBoundaryRun_bind_congr {α β : Type} (parameter : PublicParameter)
+    (f g : QueryImpl HashSpec Id) (first : OracleComp OracleWorld α) (next : α → OracleComp OracleWorld β)
+    (hfirst : fixedBoundaryRun parameter f first = fixedBoundaryRun parameter g first)
+    (hnext : ∀ value, fixedBoundaryRun parameter f (next value) = fixedBoundaryRun parameter g (next value)) :
+    fixedBoundaryRun parameter f (first >>= next) = fixedBoundaryRun parameter g (first >>= next) := by
+  simp only [fixedBoundaryRun_bind, hfirst, hnext]
+
+theorem fixedBoundaryRun_lift_prob_eq {α : Type} (parameter : PublicParameter)
+    (f g : QueryImpl HashSpec Id) (computation : ProbComp α) :
+    fixedBoundaryRun parameter f (liftM computation) = fixedBoundaryRun parameter g (liftM computation) := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => simp only [liftM_pure, fixedBoundaryRun_pure]
+  | query_bind input next ih =>
+      rw [liftM_bind]
+      apply fixedBoundaryRun_bind_congr
+      · change (simulateQ ((fixedHashWorld f).withTrace (signingBoundaryTrace parameter))
+            (liftM (OracleWorld.query (.inl input)))).run =
+          (simulateQ ((fixedHashWorld g).withTrace (signingBoundaryTrace parameter))
+            (liftM (OracleWorld.query (.inl input)))).run
+        rw [simulateQ_spec_query, simulateQ_spec_query]
+        rfl
+      · exact ih
+
+variable (parameter : PublicParameter) (words : OtsReferenceWords)
+  (f g : QueryImpl HashSpec Id) (h : AgreeOutsideOtsPrefixes parameter words f g)
+
+include h
+
+theorem boundaryEval_publicSignAttempt_eq_of_agree (root : Digest) (message : Message) (randomness : Randomness) :
+    boundaryEval parameter f (publicSignAttempt parameter root message randomness) =
+      boundaryEval parameter g (publicSignAttempt parameter root message randomness) := by
+  have hinput := h.other .message (by decide) (messageDigestPayload root message randomness)
+  simp [publicSignAttempt, messageDigest, oracleHash, boundaryEval, QueryImpl.withTrace_apply, hinput]
+
+theorem fixedBoundaryRun_publicDigestLoop_eq_of_agree (root : Digest) (message : Message) (attempts : Nat) :
+    fixedBoundaryRun parameter f (publicDigestLoop parameter root message attempts) =
+      fixedBoundaryRun parameter g (publicDigestLoop parameter root message attempts) := by
+  induction attempts with
+  | zero => simp only [publicDigestLoop, fixedBoundaryRun_pure]
+  | succ attempts ih =>
+      rw [publicDigestLoop]
+      apply fixedBoundaryRun_bind_congr
+      · exact fixedBoundaryRun_lift_prob_eq parameter f g sampleRandomness
+      · intro randomness
+        apply fixedBoundaryRun_bind_congr
+        · rw [fixedBoundaryRun_lift_hash, fixedBoundaryRun_lift_hash,
+            boundaryEval_publicSignAttempt_eq_of_agree parameter words f g h]
+        · intro attempt
+          cases attempt with
+          | none => exact ih
+          | some selected => rfl
+
+theorem frontierSigningRecord_eq_of_agree (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (frontier : OtsFrontierValues) (message : Message) :
+    frontierSigningRecord parameter root f ftsSecret words frontier message =
+      frontierSigningRecord parameter root g ftsSecret words frontier message := by
+  simp only [frontierSigningRecord, fixedBoundaryRun_publicDigestLoop_eq_of_agree parameter words f g h,
+    frontierSignAfterDigest_eq_of_agree parameter words f g h]
+
+theorem frontierSigningRun_eq_of_agree (root : Digest) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (frontier : OtsFrontierValues) (message : Message) :
+    frontierSigningRun parameter root f ftsSecret words frontier message =
+      frontierSigningRun parameter root g ftsSecret words frontier message := by
+  rw [frontierSigningRun, frontierSigningRun, frontierSigningRecord_eq_of_agree parameter words f g h]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierSigningOrigin.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierSigningOrigin.lean
new file mode 100644
index 000000000..936077ee3
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierSigningOrigin.lean
@@ -0,0 +1,140 @@
+import SphincsSecurity.Proof.Residual.RetainedResidualSigningOrigin
+import SphincsSecurity.Proof.Reference.VerifierTraceSource
+
+/-! ## CausalVerifierTrace -/
+
+namespace SphincsSecurity.Concrete.OtsContactTrace
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] frontierRoot maskOtsPrefixes
+
+theorem ContainsRun.mul_left {Result : Type} {f : QueryImpl HashSpec Id} {trace : Trace} {computation : OracleComp HashSpec Result}
+    (h : ContainsRun f trace computation) (before : Trace) : ContainsRun f (before * trace) computation := by
+  intro input hi
+  exact List.mem_append_right _ (h input hi)
+
+abbrev AdversaryTrace := ((Forgery × QueryLog SigningSpec) × SigningBoundaryTrace) × Trace
+
+end SphincsSecurity.Concrete.OtsContactTrace
+
+namespace SphincsSecurity.Concrete.ReferenceSigningWitness
+
+open _root_.OracleComp OracleSpec OtsContactTrace
+attribute [local irreducible] signDigestLoop signAfterDigest boundaryEval fixedBoundaryRun frontierSigningRun frontierAdversaryImpl frontierAdversaryRun
+set_option backward.isDefEq.respectTransparency false
+
+private theorem supported_nonzero {Result : Type} (computation : ProbComp Result) (result : Result)
+    (hr : result ∈ support computation) : 𝒟[computation] result ≠ 0 := by
+  simpa only [mem_support_iff, probOutput_def] using hr
+
+def SignatureOrigin (key : SecretKey) (f : QueryImpl HashSpec Id) (message : Message) (signature : Signature)
+    (trace : SigningBoundaryTrace) : Prop :=
+  let input := tweakableHashInput key.parameter .message (messageDigestPayload key.root message signature.randomness)
+  let digest := truncateMessageDigest (f input)
+  (input, f input) ∈ trace.messageCalls ∧ Admissible digest ∧
+    evalWithAnswerFn f (signAfterDigest key signature.randomness (digestIndex digest) (digestLeaves digest)) = some signature
+
+theorem SignatureOrigin.mono {key : SecretKey} {f : QueryImpl HashSpec Id} {message : Message} {signature : Signature}
+    {before after : SigningBoundaryTrace} (h : SignatureOrigin key f message signature before)
+    (htrace : before.messageCalls ⊆ after.messageCalls) : SignatureOrigin key f message signature after :=
+  ⟨htrace h.1, h.2⟩
+
+theorem signing_origin (key : SecretKey) (f : QueryImpl HashSpec Id) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (hfrontier : IsSigningFrontier key f words frontier)
+    (hwords : ∀ index lay, FrontierReferenceWord key.parameter f key.ftsSecret words frontier index lay)
+    (message : Message) (signature : Signature) (trace : SigningBoundaryTrace)
+    (hr : (some signature, trace) ∈ support (frontierSigningRun key.parameter key.root f key.ftsSecret words frontier message)) :
+    SignatureOrigin key f message signature trace := by
+  rw [frontierSigningRun, ← fixedBoundaryRun_signWithView_frontier key f words frontier hfrontier hwords, support_map] at hr
+  obtain ⟨⟨⟨response, view⟩, recorded⟩, hr, heq⟩ := hr
+  have hresponse : response = some signature := congrArg (fun result => result.1) heq
+  have htrace : recorded = trace := congrArg (fun result => result.2) heq
+  subst response recorded
+  have h := RetainedResidual.fixedBoundaryRun_signing_origin key f message signature view trace
+    (supported_nonzero _ _ hr)
+  exact ⟨h.2.2.2, h.2.1, h.2.2.1⟩
+
+private theorem logged_run_query_bind {Result : Type}
+    (impl : QueryImpl (OracleWorld + SigningSpec) (WriterT SigningBoundaryTrace ProbComp)) (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Result) :
+    ((simulateQ (impl.withTraceAppend signingLogFragment) (liftM (OracleSpec.query input) >>= next)).run).run =
+      (impl input).run >>= fun first =>
+        (fun tail => ((tail.1.1, signingLogFragment input first.1 ++ tail.1.2), first.2 * tail.2)) <$>
+          ((simulateQ (impl.withTraceAppend signingLogFragment) (next first.1)).run).run := by
+  simp only [simulateQ_bind, simulateQ_spec_query, QueryImpl.withTraceAppend_apply,
+    WriterT.run_bind, WriterT.run_tell, WriterT.run_monadLift', WriterT.run_map, bind_map_left, bind_assoc,
+    pure_bind, Functor.map_map]
+  rfl
+
+private theorem logged_run_origin {Result : Type} (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (impl : QueryImpl (OracleWorld + SigningSpec) (WriterT SigningBoundaryTrace ProbComp))
+    (horigin : ∀ message signature trace, (some signature, trace) ∈ support ((impl (.inr message)).run) →
+      SignatureOrigin key f message signature trace)
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) (result : (Result × QueryLog SigningSpec) × SigningBoundaryTrace)
+    (hr : result ∈ support (((simulateQ (impl.withTraceAppend signingLogFragment) computation).run).run))
+    (message : Message) (signature : Signature) (hentry : (⟨message, some signature⟩ : SigningEntry) ∈ result.1.2) :
+    SignatureOrigin key f message signature result.2 := by
+  induction computation using OracleComp.inductionOn generalizing result with
+  | pure value =>
+      simp only [simulateQ_pure, WriterT.run_pure, support_pure, Set.mem_singleton_iff] at hr
+      subst result
+      cases hentry
+  | query_bind input next ih =>
+      rw [logged_run_query_bind, mem_support_bind_iff] at hr
+      obtain ⟨first, hfirst, hr⟩ := hr
+      rw [support_map] at hr
+      obtain ⟨tail, htail, rfl⟩ := hr
+      rcases List.mem_append.mp hentry with hhead | htailEntry
+      · cases input with
+        | inl input => cases hhead
+        | inr request =>
+            have heq := List.mem_singleton.mp hhead
+            have hm : message = request := congrArg Sigma.fst heq
+            have hs : some signature = first.1 := congrArg (fun entry : SigningEntry => entry.2) heq
+            subst request
+            have hsign : (some signature, first.2) ∈ support ((impl (.inr message)).run) := by
+              simpa only [← hs] using (show (first.1, first.2) ∈ support ((impl (.inr message)).run) from hfirst)
+            apply (horigin message signature first.2 hsign).mono
+            intro entry hmem
+            rw [SigningBoundaryTrace.messageCalls_mul, List.mem_append]
+            exact Or.inl hmem
+      · apply (ih first.1 tail htail htailEntry).mono
+        intro entry hmem
+        rw [SigningBoundaryTrace.messageCalls_mul, List.mem_append]
+        exact Or.inr hmem
+
+theorem adversaryRun_origin {Result : Type} (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) (hfrontier : IsSigningFrontier key f words frontier)
+    (hwords : ∀ index lay, FrontierReferenceWord key.parameter f key.ftsSecret words frontier index lay)
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) (result : (Result × QueryLog SigningSpec) × SigningBoundaryTrace)
+    (hr : result ∈ support (frontierAdversaryRun key.parameter key.root f key.ftsSecret words frontier computation))
+    (message : Message) (signature : Signature) (hentry : (⟨message, some signature⟩ : SigningEntry) ∈ result.1.2) :
+    SignatureOrigin key f message signature result.2 := by
+  have horigin (request : Message) (signed : Signature) (trace : SigningBoundaryTrace)
+      (hs : (some signed, trace) ∈ support
+        ((frontierAdversaryImpl key.parameter key.root f key.ftsSecret words frontier (.inr request)).run)) :
+      SignatureOrigin key f request signed trace := by
+    rw [frontierAdversaryImpl, WriterT.run_mk] at hs
+    exact signing_origin key f words frontier hfrontier hwords request signed trace hs
+  rw [frontierAdversaryRun] at hr
+  exact logged_run_origin key f (frontierAdversaryImpl key.parameter key.root f key.ftsSecret words frontier)
+    horigin computation result hr message signature hentry
+
+theorem fixedTrace_origin {Result : Type} (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) (hfrontier : IsSigningFrontier key f words frontier)
+    (hwords : ∀ index lay, FrontierReferenceWord key.parameter f key.ftsSecret words frontier index lay)
+    (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (result : ((Result × QueryLog SigningSpec) × SigningBoundaryTrace) × Trace)
+    (hr : result ∈ support (fixedTrace f
+      (CausalFrontierProgram.adversaryRun key.parameter key.root f key.ftsSecret words frontier computation)))
+    (message : Message) (signature : Signature) (hentry : (⟨message, some signature⟩ : SigningEntry) ∈ result.1.1.2) :
+    SignatureOrigin key f message signature result.1.2 := by
+  have hbase : result.1 ∈ support (Prod.fst <$> fixedTrace f
+      (CausalFrontierProgram.adversaryRun key.parameter key.root f key.ftsSecret words frontier computation)) := by
+    rw [support_map]
+    exact ⟨result, hr, rfl⟩
+  rw [fixedTrace_forget, CausalFrontierProgram.fixed_adversaryRun] at hbase
+  exact adversaryRun_origin key f words frontier hfrontier hwords computation result.1 hbase message signature hentry
+
+end SphincsSecurity.Concrete.ReferenceSigningWitness
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierTreeEvaluation.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierTreeEvaluation.lean
new file mode 100644
index 000000000..c6c16795c
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/FrontierTreeEvaluation.lean
@@ -0,0 +1,128 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.Extract
+import SphincsSecurity.Proof.Ots.OneTime
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+def frontierOneTimePublicKey (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex)
+    (leaf : LeafIndex) (digits : Encoding) (frontier : ChainIndex → Digest) :
+    OracleComp HashSpec (ChainIndex → Digest) :=
+  sequenceFin fun chainIdx => recoverChain parameter lay tree leaf chainIdx (digits chainIdx) (frontier chainIdx)
+
+def frontierTreeNode (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex)
+    (digits : LeafIndex → Encoding) (frontier : LeafIndex → ChainIndex → Digest) :
+    Nat → Nat → OracleComp HashSpec Digest
+  | 0, nodeIdx => do
+      let leaf := leafOfNat nodeIdx
+      let endpoints ← frontierOneTimePublicKey parameter lay tree leaf (digits leaf) (frontier leaf)
+      leafHash parameter lay tree leaf endpoints
+  | level + 1, nodeIdx => do
+      let left ← frontierTreeNode parameter lay tree digits frontier level (2 * nodeIdx)
+      let right ← frontierTreeNode parameter lay tree digits frontier level (2 * nodeIdx + 1)
+      tweakableHash parameter (.node lay tree (level + 1) nodeIdx) (nodePayload left right)
+
+def frontierTreePath (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex)
+    (digits : LeafIndex → Encoding) (frontier : LeafIndex → ChainIndex → Digest) (leaf : LeafIndex) :
+    OracleComp HashSpec (Fin maxLayerHeight → Digest) :=
+  sequenceFin fun level =>
+    if level.val < layerHeight lay then
+      frontierTreeNode parameter lay tree digits frontier level.val (Nat.xor (leaf.val / 2 ^ level.val) 1)
+    else pure 0
+
+def IsOtsFrontier (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (lay : Layer) (tree : TreeIndex) (secret : LeafIndex → ChainIndex → Digest)
+    (digits : LeafIndex → Encoding) (frontier : LeafIndex → ChainIndex → Digest) : Prop :=
+  ∀ leaf chainIdx, evalWithAnswerFn f
+    (chainWalk parameter lay tree leaf chainIdx 0 (digits leaf chainIdx).val (secret leaf chainIdx)) =
+      frontier leaf chainIdx
+
+theorem eval_frontierOneTimePublicKey (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (secret frontier : ChainIndex → Digest)
+    (digits : Encoding)
+    (hfrontier : ∀ chainIdx, evalWithAnswerFn f
+      (chainWalk parameter lay tree leaf chainIdx 0 (digits chainIdx).val (secret chainIdx)) = frontier chainIdx) :
+    evalWithAnswerFn f (frontierOneTimePublicKey parameter lay tree leaf digits frontier) =
+      evalWithAnswerFn f (oneTimePublicKey parameter lay tree leaf secret) := by
+  simp only [frontierOneTimePublicKey, evalWithAnswerFn_sequenceFin, eval_oneTimePublicKey]
+  funext chainIdx
+  rw [← hfrontier chainIdx, eval_recoverChain]
+
+theorem eval_frontierTreeNode (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (lay : Layer) (tree : TreeIndex) (secret : LeafIndex → ChainIndex → Digest)
+    (digits : LeafIndex → Encoding) (frontier : LeafIndex → ChainIndex → Digest)
+    (hfrontier : IsOtsFrontier parameter f lay tree secret digits frontier) (level nodeIdx : Nat) :
+    evalWithAnswerFn f (frontierTreeNode parameter lay tree digits frontier level nodeIdx) =
+      evalWithAnswerFn f (treeNode parameter lay tree secret level nodeIdx) := by
+  induction level generalizing nodeIdx with
+  | zero =>
+      rw [frontierTreeNode, treeNode_zero_eq, evalWithAnswerFn_bind, evalWithAnswerFn_bind,
+        eval_frontierOneTimePublicKey _ _ _ _ _ _ _ _ (hfrontier _)]
+  | succ level ih =>
+      simp only [frontierTreeNode, treeNode_succ_eq, evalWithAnswerFn_bind, ih]
+
+theorem eval_frontierTreePath (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (lay : Layer) (tree : TreeIndex) (secret : LeafIndex → ChainIndex → Digest)
+    (digits : LeafIndex → Encoding) (frontier : LeafIndex → ChainIndex → Digest)
+    (hfrontier : IsOtsFrontier parameter f lay tree secret digits frontier) (leaf : LeafIndex) :
+    evalWithAnswerFn f (frontierTreePath parameter lay tree digits frontier leaf) =
+      evalWithAnswerFn f (treePath parameter lay tree secret leaf) := by
+  simp only [frontierTreePath, treePath, evalWithAnswerFn_sequenceFin]
+  funext level
+  split_ifs
+  · exact eval_frontierTreeNode _ _ _ _ _ _ _ hfrontier _ _
+  · rfl
+
+theorem eval_chainWalk_congr_tail (parameter : PublicParameter) (f g : QueryImpl HashSpec Id)
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (chainIdx : ChainIndex)
+    (start steps : Nat) (value : Digest) (hsteps : start + steps ≤ chainLength - 1)
+    (hhash : ∀ (step : Fin (chainLength - 1)), start ≤ step.val → ∀ input : Digest,
+      truncateHash (f (tweakableHashInput parameter (.chain lay tree leaf chainIdx step) (digestBytes input))) =
+        truncateHash (g (tweakableHashInput parameter (.chain lay tree leaf chainIdx step) (digestBytes input)))) :
+    evalWithAnswerFn f (chainWalk parameter lay tree leaf chainIdx start steps value) =
+      evalWithAnswerFn g (chainWalk parameter lay tree leaf chainIdx start steps value) := by
+  induction steps with
+  | zero => rfl
+  | succ steps ih =>
+      have hstep : start + steps < chainLength - 1 := by omega
+      simp only [chainWalk, evalWithAnswerFn_bind, dif_pos hstep, eval_tweakableHash]
+      rw [ih (by omega)]
+      exact hhash ⟨start + steps, hstep⟩ (Nat.le_add_right start steps) _
+
+theorem eval_frontierTreeNode_congr (parameter : PublicParameter) (f g : QueryImpl HashSpec Id)
+    (lay : Layer) (tree : TreeIndex) (digits : LeafIndex → Encoding)
+    (frontier : LeafIndex → ChainIndex → Digest)
+    (hchain : ∀ (leaf : LeafIndex) (chainIdx : ChainIndex) (step : Fin (chainLength - 1)),
+      (digits leaf chainIdx).val ≤ step.val → ∀ input : Digest,
+      truncateHash (f (tweakableHashInput parameter (.chain lay tree leaf chainIdx step) (digestBytes input))) =
+        truncateHash (g (tweakableHashInput parameter (.chain lay tree leaf chainIdx step) (digestBytes input))))
+    (hleaf : ∀ (leaf : LeafIndex) (payload : HashInput),
+      truncateHash (f (tweakableHashInput parameter (.leaf lay tree leaf) payload)) =
+        truncateHash (g (tweakableHashInput parameter (.leaf lay tree leaf) payload)))
+    (hnode : ∀ (level nodeIdx : Nat) (payload : HashInput),
+      truncateHash (f (tweakableHashInput parameter (.node lay tree level nodeIdx) payload)) =
+        truncateHash (g (tweakableHashInput parameter (.node lay tree level nodeIdx) payload)))
+    (level nodeIdx : Nat) :
+    evalWithAnswerFn f (frontierTreeNode parameter lay tree digits frontier level nodeIdx) =
+      evalWithAnswerFn g (frontierTreeNode parameter lay tree digits frontier level nodeIdx) := by
+  have hkey : ∀ leaf, evalWithAnswerFn f
+      (frontierOneTimePublicKey parameter lay tree leaf (digits leaf) (frontier leaf)) =
+        evalWithAnswerFn g (frontierOneTimePublicKey parameter lay tree leaf (digits leaf) (frontier leaf)) := by
+    intro leaf
+    simp only [frontierOneTimePublicKey, evalWithAnswerFn_sequenceFin]
+    funext chainIdx
+    apply eval_chainWalk_congr_tail _ _ _ _ _ _ _ _ _ _ _ (hchain leaf chainIdx)
+    have hdigit := (digits leaf chainIdx).isLt
+    simp only [chainLength, winternitzBits] at hdigit ⊢
+    omega
+  induction level generalizing nodeIdx with
+  | zero =>
+      simp only [frontierTreeNode, evalWithAnswerFn_bind, leafHash, eval_tweakableHash]
+      rw [hkey]
+      exact hleaf _ _
+  | succ level ih =>
+      simp only [frontierTreeNode, evalWithAnswerFn_bind, eval_tweakableHash, ih]
+      exact hnode _ _ _
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/GraphPayloadInputs.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/GraphPayloadInputs.lean
new file mode 100644
index 000000000..27656ae2a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/GraphPayloadInputs.lean
@@ -0,0 +1,32 @@
+import SphincsSecurity.Proof.Hypertree.CanonicalGraphSampling
+namespace SphincsSecurity.Concrete
+
+attribute [local irreducible] canonicalPayloadInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+theorem digestBytes_mem_canonicalPayloadInputs (value : Digest) : digestBytes value ∈ canonicalPayloadInputs := by
+  simpa only [List.flatMap_cons, List.flatMap_nil, List.append_nil] using
+    flatMap_mem_canonicalPayloadInputs [value] (by change 1 ≤ numChains; decide)
+
+theorem nodePayload_mem_canonicalPayloadInputs (left right : Digest) : nodePayload left right ∈ canonicalPayloadInputs := by
+  simpa only [nodePayload, List.flatMap_cons, List.flatMap_nil, List.append_nil] using
+    flatMap_mem_canonicalPayloadInputs [left, right] (by change 2 ≤ numChains; decide)
+
+theorem orderedPayload_mem_canonicalPayloadInputs (order : Bool) (left right : Digest) :
+    orderedPayload order left right ∈ canonicalPayloadInputs := by
+  cases order <;> exact nodePayload_mem_canonicalPayloadInputs _ _
+
+theorem leafPayload_mem_canonicalPayloadInputs (values : ChainIndex → Digest) : leafPayload values ∈ canonicalPayloadInputs :=
+  flatMap_mem_canonicalPayloadInputs (List.ofFn values) (by simp only [List.length_ofFn, le_refl])
+
+theorem ftsRootsPayload_mem_canonicalPayloadInputs (values : FtsTree → Digest) : ftsRootsPayload values ∈ canonicalPayloadInputs :=
+  flatMap_mem_canonicalPayloadInputs (List.ofFn values) (by simp only [List.length_ofFn]; decide)
+
+theorem graphInput_mem_of_payload (parameter : PublicParameter) (position : Position) (payload : HashInput)
+    (hp : payload ∈ canonicalPayloadInputs) : tweakableHashInput parameter position.domain payload ∈ canonicalGraphInputs parameter := by
+  classical
+  rw [canonicalGraphInputs, Finset.mem_biUnion]
+  simp only [Finset.mem_univ, true_and]
+  exact ⟨position, Finset.mem_image.mpr ⟨payload, hp, rfl⟩⟩
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/Honest.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/Honest.lean
new file mode 100644
index 000000000..71d677add
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/Honest.lean
@@ -0,0 +1,248 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.ExtractFts
+import SphincsSecurity.Proof.Ots.ExtractOts
+import SphincsSecurity.Proof.Hypertree.Position
+/-!
+# 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
+
+/-- **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
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/Hypertree.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/Hypertree.lean
new file mode 100644
index 000000000..472e3e535
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/Hypertree.lean
@@ -0,0 +1,35 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Scheme.StatementLemmas
+/-!
+# 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 _)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/Position.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/Position.lean
new file mode 100644
index 000000000..b65afbd7c
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/Position.lean
@@ -0,0 +1,155 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Scheme.Bytes
+/-!
+# 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 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. -/
+
+/-- 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/Hypertree/PublicGraphOpenings.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/PublicGraphOpenings.lean
new file mode 100644
index 000000000..0d1384d23
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/PublicGraphOpenings.lean
@@ -0,0 +1,146 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.CanonicalGraphHonest
+import SphincsSecurity.Proof.Hypertree.CanonicalProbeRouting
+import SphincsSecurity.Proof.Fts.FtsProbeGame
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] instFintypePosition
+
+theorem openingSibling_lt (height leaf level : Nat) (hlevel : level < height) (hleaf : leaf < 2 ^ height) :
+    Nat.xor (leaf / 2 ^ level) 1 < 2 ^ height := by
+  have hspan := FtsProbeSimulation.sibling_node_bound height leaf level hlevel hleaf
+  have hpow : 1 ≤ (2 : Nat) ^ level := Nat.one_le_pow level 2 (by decide)
+  nlinarith
+
+def treeOpeningPosition (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex)
+    (level : Fin maxLayerHeight) : Position :=
+  let sibling : LeafIndex := ⟨Nat.xor (leaf.val / 2 ^ level.val) 1,
+    openingSibling_lt maxLayerHeight leaf.val level.val level.isLt leaf.isLt⟩
+  if level.val = 0 then .leaf lay tree sibling
+  else .node lay tree ⟨level.val - 1, by have := level.isLt; omega⟩ sibling
+
+def ftsOpeningPosition (index : Index) (tree : FtsTree) (leaf : FtsLeaf)
+    (level : Fin ftsTreeHeight) : Position :=
+  let sibling : FtsLeaf := ⟨Nat.xor (leaf.val / 2 ^ level.val) 1,
+    openingSibling_lt ftsTreeHeight leaf.val level.val level.isLt leaf.isLt⟩
+  if level.val = 0 then .ftsLeaf index tree sibling
+  else .ftsNode index tree ⟨level.val - 1, by have := level.isLt; omega⟩ sibling
+
+theorem treeOpeningPosition_bound (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (level : Fin maxLayerHeight) :
+    (treeOpeningPosition lay tree leaf level).TreeBound := by
+  unfold treeOpeningPosition
+  split_ifs with hzero
+  · trivial
+  · simp only [Position.TreeBound, show level.val - 1 + 1 = level.val by omega]
+    exact FtsProbeSimulation.sibling_node_bound maxLayerHeight leaf.val level.val level.isLt leaf.isLt
+
+theorem ftsOpeningPosition_bound (index : Index) (tree : FtsTree) (leaf : FtsLeaf) (level : Fin ftsTreeHeight) :
+    (ftsOpeningPosition index tree leaf level).TreeBound := by
+  unfold ftsOpeningPosition
+  split_ifs with hzero
+  · trivial
+  · simp only [Position.TreeBound, show level.val - 1 + 1 = level.val by omega]
+    exact FtsProbeSimulation.sibling_node_bound ftsTreeHeight leaf.val level.val level.isLt leaf.isLt
+
+theorem treeOpeningPosition_public (words : OtsReferenceWords) (disclosed : Index → FtsTree → FtsLeaf → Prop)
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (level : Fin maxLayerHeight) :
+    ¬CanonicalCoordinate.Hidden words disclosed (.graph (treeOpeningPosition lay tree leaf level)) := by
+  unfold treeOpeningPosition
+  split_ifs <;> simp only [CanonicalCoordinate.Hidden, not_false_eq_true]
+
+theorem ftsOpeningPosition_public (words : OtsReferenceWords) (disclosed : Index → FtsTree → FtsLeaf → Prop)
+    (index : Index) (tree : FtsTree) (leaf : FtsLeaf) (level : Fin ftsTreeHeight) :
+    ¬CanonicalCoordinate.Hidden words disclosed (.graph (ftsOpeningPosition index tree leaf level)) := by
+  unfold ftsOpeningPosition
+  split_ifs <;> simp only [CanonicalCoordinate.Hidden, not_false_eq_true]
+
+def knownTreePath (known : Labels) (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) : Fin maxLayerHeight → Digest :=
+  fun level => if level.val < layerHeight lay then known (.graph (treeOpeningPosition lay tree leaf level)) else 0
+
+def knownFtsPath (known : Labels) (index : Index) (leaves : IndexGroup → FtsLeaf) : FtsTree → Fin ftsTreeHeight → Digest :=
+  fun tree level => known (.graph (ftsOpeningPosition index tree (leaves (ftsIndexOf tree)) level))
+
+variable (parameter : PublicParameter)
+  (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+  (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (f : QueryImpl HashSpec Id)
+
+theorem canonicalGraph_treeOpening (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (level : Fin maxLayerHeight) :
+    truncateHash (canonicalGraphLabels parameter otsSecret ftsSecret f (treeOpeningPosition lay tree leaf level)) =
+      evalWithAnswerFn f (treeNode parameter lay tree (otsSecret lay tree) level.val (Nat.xor (leaf.val / 2 ^ level.val) 1)) := by
+  rw [canonicalGraphLabels_eq_honest parameter otsSecret ftsSecret f _ (treeOpeningPosition_bound lay tree leaf level)]
+  change honestValue f parameter otsSecret ftsSecret (treeOpeningPosition lay tree leaf level) = _
+  unfold treeOpeningPosition
+  split_ifs with hzero
+  · rw [honestValue_leaf]
+    simp only [hzero, honestNode]
+  · rw [honestValue_node, show level.val - 1 + 1 = level.val by omega]
+    rfl
+
+theorem canonicalGraph_ftsOpening (index : Index) (tree : FtsTree) (leaf : FtsLeaf) (level : Fin ftsTreeHeight) :
+    truncateHash (canonicalGraphLabels parameter otsSecret ftsSecret f (ftsOpeningPosition index tree leaf level)) =
+      evalWithAnswerFn f (ftsNode parameter index tree (ftsSecret index tree) level.val (Nat.xor (leaf.val / 2 ^ level.val) 1)) := by
+  rw [canonicalGraphLabels_eq_honest parameter otsSecret ftsSecret f _ (ftsOpeningPosition_bound index tree leaf level)]
+  change honestValue f parameter otsSecret ftsSecret (ftsOpeningPosition index tree leaf level) = _
+  unfold ftsOpeningPosition
+  split_ifs with hzero
+  · rw [honestValue_ftsLeaf]
+    simp only [hzero, honestFtsNode]
+  · rw [honestValue_ftsNode, show level.val - 1 + 1 = level.val by omega]
+    rfl
+
+theorem knownTreePath_eq (words : OtsReferenceWords) (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels)
+    (hagrees : PublicAgreement words disclosed known
+      (CanonicalCoordinate.value otsSecret ftsSecret (canonicalGraphLabels parameter otsSecret ftsSecret f)))
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) :
+    knownTreePath known lay tree leaf = evalWithAnswerFn f (treePath parameter lay tree (otsSecret lay tree) leaf) := by
+  simp only [treePath, evalWithAnswerFn_sequenceFin]
+  funext level
+  rw [knownTreePath]
+  split_ifs
+  · rw [hagrees _ (treeOpeningPosition_public words disclosed lay tree leaf level)]
+    exact canonicalGraph_treeOpening parameter otsSecret ftsSecret f lay tree leaf level
+  · rfl
+
+theorem knownFtsPath_eq (words : OtsReferenceWords) (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels)
+    (hagrees : PublicAgreement words disclosed known
+      (CanonicalCoordinate.value otsSecret ftsSecret (canonicalGraphLabels parameter otsSecret ftsSecret f)))
+    (index : Index) (leaves : IndexGroup → FtsLeaf) :
+    knownFtsPath known index leaves = evalWithAnswerFn f (ftsOpen parameter index leaves (ftsSecret index)) := by
+  simp only [ftsOpen, evalWithAnswerFn_sequenceFin]
+  funext tree level
+  rw [knownFtsPath, hagrees _ (ftsOpeningPosition_public words disclosed index tree (leaves (ftsIndexOf tree)) level)]
+  exact canonicalGraph_ftsOpening parameter otsSecret ftsSecret f index tree (leaves (ftsIndexOf tree)) level
+
+def knownFrontier (known : Labels) (words : OtsReferenceWords) : OtsFrontierValues :=
+  fun lay tree leaf chain =>
+    if hzero : (words lay tree leaf chain).val = 0 then known (.otsStart lay tree leaf chain)
+    else known (.graph (.chain lay tree leaf chain
+      ⟨(words lay tree leaf chain).val - 1, by
+        have hdigit := (words lay tree leaf chain).isLt
+        simp only [chainLength, winternitzBits] at hdigit ⊢
+        omega⟩))
+
+theorem knownFrontier_eq (labels : CanonicalGraphLabels) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels)
+    (hagrees : PublicAgreement words disclosed known (CanonicalCoordinate.value otsSecret ftsSecret labels)) :
+    knownFrontier known words = canonicalGraphFrontier otsSecret labels words := by
+  funext lay tree leaf chain
+  rw [knownFrontier, canonicalGraphFrontier]
+  split_ifs with hzero
+  · exact hagrees _ (by simp only [CanonicalCoordinate.Hidden, hzero, lt_self_iff_false, not_false_eq_true])
+  · apply hagrees
+    simp only [CanonicalCoordinate.Hidden]
+    omega
+
+def knownRoot (known : Labels) : Digest :=
+  known (.graph (.node topLayer rootTree ⟨maxLayerHeight - 1, by decide⟩ ⟨0, by positivity⟩))
+
+theorem knownRoot_eq (labels : CanonicalGraphLabels) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels)
+    (hagrees : PublicAgreement words disclosed known (CanonicalCoordinate.value otsSecret ftsSecret labels)) :
+    knownRoot known = canonicalGraphRoot labels :=
+  hagrees _ (by simp only [CanonicalCoordinate.Hidden, not_false_eq_true])
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/PublicGraphSigner.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/PublicGraphSigner.lean
new file mode 100644
index 000000000..1b9e7783f
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/PublicGraphSigner.lean
@@ -0,0 +1,95 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Ots.EncodingFamilyOracleSplit
+import SphincsSecurity.Proof.Hypertree.PublicGraphOpenings
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] instFintypePosition boundaryEval referenceEncodingSearch
+
+def publicSignLayer (known : Labels) (words : OtsReferenceWords) (selections : ReferenceFamily)
+    (index : Index) (lay : Layer) : Option LayerPart × Nat :=
+  let search := referenceSelectionResult (selections ⟨lay, treeIndexAt index lay, leafIndexAt index lay⟩)
+  let cost := layerMessageHashCost lay + search.2
+  match search.1 with
+  | none => (none, cost)
+  | some (counter, _) =>
+      (some (counter, knownFrontier known words lay (treeIndexAt index lay) (leafIndexAt index lay),
+        knownTreePath known lay (treeIndexAt index lay) (leafIndexAt index lay)),
+        cost + 191 + authenticationHashCost lay)
+
+structure PublicSigningPlan where
+  randomness : Randomness
+  ftsPath : FtsTree → Fin ftsTreeHeight → Digest
+  parts : Layer → LayerPart
+
+def PublicSigningPlan.finish (plan : PublicSigningPlan) (secrets : FtsTree → Digest) : Signature where
+  randomness := plan.randomness
+  ftsSecret := secrets
+  ftsPath := plan.ftsPath
+  counter := fun lay => (plan.parts lay).1
+  chainValue := fun lay => (plan.parts lay).2.1
+  authPath := flattenPaths fun lay => (plan.parts lay).2.2
+
+def publicSignPlan (known : Labels) (words : OtsReferenceWords) (selections : ReferenceFamily)
+    (randomness : Randomness) (index : Index) (leaves : IndexGroup → FtsLeaf) : Option PublicSigningPlan × Nat :=
+  let layers := fun lay => publicSignLayer known words selections index lay
+  ((sequenceFin (m := Option) (fun lay => (layers lay).1)).map (fun parts =>
+      ⟨randomness, knownFtsPath known index leaves, parts⟩),
+    28504 + ∑ lay, (layers lay).2)
+
+variable (key : SecretKey) (f : QueryImpl HashSpec Id) (words : OtsReferenceWords)
+  (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels)
+  (hagrees : PublicAgreement words disclosed known
+    (CanonicalCoordinate.value key.otsSecret key.ftsSecret (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f)))
+
+include hagrees in
+theorem frontierSignLayer_eq_public (index : Index) (lay : Layer) :
+    frontierSignLayer key.parameter f key.ftsSecret words
+        (canonicalGraphFrontier key.otsSecret (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f) words) index lay =
+      publicSignLayer known words (referenceTableSelection key f) index lay := by
+  have hfrontier : IsSigningFrontier key f words
+      (canonicalGraphFrontier key.otsSecret (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f) words) := by
+    rw [canonicalGraphLabels_frontier key.parameter key.otsSecret key.ftsSecret f words key.root]
+    exact isSigningFrontier_canonical key f words
+  have hsearch : frontierLayerSearch key.parameter f key.ftsSecret words
+      (canonicalGraphFrontier key.otsSecret (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f) words) index lay =
+        referenceSelectionResult (referenceTableSelection key f ⟨lay, treeIndexAt index lay, leafIndexAt index lay⟩) := by
+    rw [referenceSelectionResult_eq_search, canonicalEncodingSearch_at, frontierLayerSearch,
+      eval_frontierLayerMessage key f words _ hfrontier index lay]
+  have hpath := eval_frontierTreePath key.parameter f lay (treeIndexAt index lay)
+    (key.otsSecret lay (treeIndexAt index lay)) (words lay (treeIndexAt index lay))
+    (canonicalGraphFrontier key.otsSecret (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f) words lay
+      (treeIndexAt index lay)) (hfrontier lay (treeIndexAt index lay)) (leafIndexAt index lay)
+  rw [← knownTreePath_eq key.parameter key.otsSecret key.ftsSecret f words disclosed known hagrees] at hpath
+  simp only [frontierSignLayer, publicSignLayer, hsearch, hpath,
+    knownFrontier_eq key.otsSecret key.ftsSecret _ words disclosed known hagrees]
+  rfl
+
+include hagrees in
+theorem frontierSignAfterDigest_eq_publicPlan (randomness : Randomness) (index : Index) (leaves : IndexGroup → FtsLeaf) :
+    frontierSignAfterDigest key.parameter f key.ftsSecret words
+        (canonicalGraphFrontier key.otsSecret (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f) words)
+        randomness index leaves =
+      ((publicSignPlan known words (referenceTableSelection key f) randomness index leaves).1.map
+        (fun plan => plan.finish (fun tree => key.ftsSecret index tree (leaves (ftsIndexOf tree)))),
+        (publicSignPlan known words (referenceTableSelection key f) randomness index leaves).2) := by
+  simp only [frontierSignAfterDigest, publicSignPlan,
+    frontierSignLayer_eq_public key f words disclosed known hagrees,
+    ← knownFtsPath_eq key.parameter key.otsSecret key.ftsSecret f words disclosed known hagrees,
+    Option.map_map, Function.comp_def, PublicSigningPlan.finish]
+
+theorem boundaryEval_signAfterDigest_public (dummy : OtsReferenceWords)
+    (hagrees : PublicAgreement (canonicalReferenceWords key f dummy) disclosed known
+      (CanonicalCoordinate.value key.otsSecret key.ftsSecret (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f)))
+    (randomness : Randomness) (index : Index) (leaves : IndexGroup → FtsLeaf) :
+    boundaryEval key.parameter f (signAfterDigest key randomness index leaves) =
+      ((publicSignPlan known (canonicalReferenceWords key f dummy) (referenceTableSelection key f) randomness index leaves).1.map
+        (fun plan => plan.finish (fun tree => key.ftsSecret index tree (leaves (ftsIndexOf tree)))),
+        (FreeMonoid.of none) ^
+          (publicSignPlan known (canonicalReferenceWords key f dummy) (referenceTableSelection key f) randomness index leaves).2) := by
+  have h := frontierSignAfterDigest_eq_publicPlan key f (canonicalReferenceWords key f dummy) disclosed known hagrees randomness index leaves
+  rw [canonicalGraphLabels_frontier key.parameter key.otsSecret key.ftsSecret f _ key.root] at h
+  rw [boundaryEval_signAfterDigest_canonical key f dummy, h]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/ReferenceGraphContext.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/ReferenceGraphContext.lean
new file mode 100644
index 000000000..ce0c0c250
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/ReferenceGraphContext.lean
@@ -0,0 +1,119 @@
+import SphincsSecurity.Proof.Hypertree.StructuralOracleSplit
+import SphincsSecurity.Proof.Reference.ReferenceInstrumentedGame
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition Finset.univ
+
+noncomputable local instance (inputs : Finset HashInput) : SampleableType (inputs → HashOutput) := SampleableType.ofFintype _
+
+noncomputable local instance : SampleableType CanonicalGraphLabels := SampleableType.ofFintype _
+
+theorem referenceFamilyOracleSample_graph_bind {Result : Type} (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (hgraph : canonicalGraphInputs key.parameter ⊆ inputs)
+    (next : QueryImpl HashSpec Id → CanonicalGraphLabels → ReferenceFamily → ProbComp Result) :
+    (𝒟[referenceFamilyOracleSample key inputs hencoding] >>= fun reference =>
+      let f := finiteHashAnswer ∅ inputs reference.2
+      𝒟[next f (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f) reference.1]) =
+      𝒟[do
+        let labels ← ($ᵗ CanonicalGraphLabels : ProbComp _)
+        let residual ← sampleHashTable inputs
+        let f := programmedHash key.parameter key.otsSecret key.ftsSecret labels (finiteHashAnswer ∅ inputs residual)
+        next f labels (referenceTableSelection key f)] := by
+  rw [referenceFamilyOracleSample_bind_selected key inputs hencoding hgraph
+    (fun selections table => next (finiteHashAnswer ∅ inputs table)
+      (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret (finiteHashAnswer ∅ inputs table)) selections)]
+  rw [evalDist_canonicalGraph_bind_eq_plant key.parameter key.otsSecret key.ftsSecret inputs hgraph
+    (fun labels table => next (finiteHashAnswer ∅ inputs table) labels (referenceTableSelection key (finiteHashAnswer ∅ inputs table)))]
+  rw [evalDist_plantCanonicalGraph_bind_eq_residual key.parameter key.otsSecret key.ftsSecret inputs hgraph
+    (fun labels table => next (finiteHashAnswer ∅ inputs table) labels (referenceTableSelection key (finiteHashAnswer ∅ inputs table)))]
+  simp only [finiteHashAnswer_program_eq]
+
+noncomputable def referenceGraphContextRest {Result : Type} (observer : FrontierObserver Result)
+    (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) : SPMF (CanonicalGraphLabels × ReferenceFamily × Result) := do
+  let reference ← 𝒟[referenceFamilyOracleSample key inputs hencoding]
+  let f := finiteHashAnswer ∅ inputs reference.2
+  let labels := canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f
+  let result ← 𝒟[referenceInstrumentedRest observer key f labels reference.1 dummy adversary]
+  pure (labels, reference.1, result)
+
+theorem referenceGraphContextRest_residual {Result : Type} (observer : FrontierObserver Result)
+    (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+    (hgraph : canonicalGraphInputs key.parameter ⊆ inputs) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    referenceGraphContextRest observer key inputs hencoding dummy adversary = (do
+      let labels ← 𝒟[PMF.uniformOfFintype CanonicalGraphLabels]
+      let residual ← 𝒟[PMF.uniformOfFintype (inputs → HashOutput)]
+      let f := programmedHash key.parameter key.otsSecret key.ftsSecret labels (finiteHashAnswer ∅ inputs residual)
+      let selections := referenceTableSelection key f
+      let result ← 𝒟[referenceInstrumentedRest observer key f labels selections dummy adversary]
+      pure (labels, selections, result)) := by
+  have h := referenceFamilyOracleSample_graph_bind key inputs hencoding hgraph
+    (fun f labels selections => do
+      let result ← referenceInstrumentedRest observer key f labels selections dummy adversary
+      pure (labels, selections, result))
+  simpa only [referenceGraphContextRest, evalDist_bind, evalDist_pure, evalDist_uniformSample, sampleHashTable] using h
+
+theorem uniformStructural_split (parameter : PublicParameter) (inputs : Finset HashInput) :
+    𝒟[PMF.uniformOfFintype (inputs → HashOutput)] = (do
+      let outside ← 𝒟[PMF.uniformOfFintype (NonstructuralRows parameter inputs)]
+      let rows ← 𝒟[PMF.uniformOfFintype (structuralInputs parameter inputs → HashOutput)]
+      pure (joinStructuralTable parameter inputs rows outside)) := by
+  have h := (UniformTableSplit.uniform_join (structuralInputCell parameter inputs) (structuralInputCell_injective parameter inputs)
+    (Answer := HashOutput)).trans (PMF.bind_comm
+      (PMF.uniformOfFintype (structuralInputs parameter inputs → HashOutput))
+      (PMF.uniformOfFintype (NonstructuralRows parameter inputs))
+      (fun rows outside => PMF.pure (joinStructuralTable parameter inputs rows outside)))
+  have hd := congrArg (fun law : PMF (inputs → HashOutput) => 𝒟[law]) h
+  simpa only [← PMF.monad_bind_eq_bind, ← PMF.monad_pure_eq_pure, evalDist_bind, evalDist_pure,
+    Function.comp_def, joinStructuralTable] using hd
+
+theorem referenceGraphContextRest_conditioned {Result : Type} (observer : FrontierObserver Result)
+    (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+    (hgraph : canonicalGraphInputs key.parameter ⊆ inputs) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    referenceGraphContextRest observer key inputs hencoding dummy adversary = (do
+      let labels ← 𝒟[PMF.uniformOfFintype CanonicalGraphLabels]
+      let outside ← 𝒟[PMF.uniformOfFintype (NonstructuralRows key.parameter inputs)]
+      let selections := referenceTableSelection key (structuralAnswer key inputs labels outside (fun _ => 0))
+      let words := referenceFamilyWords selections dummy
+      let rows ← 𝒟[PMF.uniformOfFintype (structuralInputs key.parameter inputs → HashOutput)]
+      let result ← 𝒟[simulateQ (fixedHashWorld (structuralAnswer key inputs labels outside rows))
+        (observer key.parameter words (canonicalGraphFrontier key.otsSecret labels words)
+          (structuralProgram key inputs labels outside words adversary))]
+      pure (labels, selections, result)) := by
+  rw [referenceGraphContextRest_residual observer key inputs hencoding hgraph dummy adversary, uniformStructural_split]
+  simp only [bind_assoc, pure_bind]
+  apply congrArg (𝒟[PMF.uniformOfFintype CanonicalGraphLabels] >>= ·)
+  funext labels
+  apply congrArg (𝒟[PMF.uniformOfFintype (NonstructuralRows key.parameter inputs)] >>= ·)
+  funext outside
+  apply congrArg (𝒟[PMF.uniformOfFintype (structuralInputs key.parameter inputs → HashOutput)] >>= ·)
+  funext rows
+  change (𝒟[referenceInstrumentedRest observer key (structuralAnswer key inputs labels outside rows) labels
+      (referenceTableSelection key (structuralAnswer key inputs labels outside rows)) dummy adversary] >>= fun result =>
+        pure (labels, referenceTableSelection key (structuralAnswer key inputs labels outside rows), result)) = _
+  rw [structuralAnswer_selections key inputs labels outside rows (fun _ => 0), referenceInstrumentedRest, structuralProgram_eq]
+
+abbrev GraphContextResult (Result : Type) := SecretKey × CanonicalGraphLabels × ReferenceFamily × Result
+
+noncomputable def referenceGraphContextGame {Result : Type} (observer : FrontierObserver Result)
+    (inputs : Finset HashInput) (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) : SPMF (GraphContextResult Result) := do
+  let parameter ← 𝒟[sampleParameter]
+  let otsSecret ← 𝒟[sampleOtsSecrets]
+  let ftsSecret ← 𝒟[sampleFtsSecrets]
+  let key : SecretKey := ⟨parameter, 0, otsSecret, ftsSecret⟩
+  let result ← referenceGraphContextRest observer key inputs (hencoding parameter) dummy adversary
+  pure (key, result)
+
+theorem referenceGraphContextGame_erased {Result : Type} (observer : FrontierObserver Result)
+    (inputs : Finset HashInput) (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (fun result : GraphContextResult Result => (result.1.parameter, result.2.2.1, result.2.2.2)) <$>
+      referenceGraphContextGame observer inputs hencoding dummy adversary =
+        referenceInstrumentedGame observer inputs hencoding dummy adversary := by
+  simp only [referenceGraphContextGame, referenceGraphContextRest, referenceInstrumentedGame,
+    map_bind, map_pure, bind_assoc, pure_bind]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/ReferenceGraphProgram.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/ReferenceGraphProgram.lean
new file mode 100644
index 000000000..569985f1f
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/ReferenceGraphProgram.lean
@@ -0,0 +1,114 @@
+import SphincsSecurity.Proof.Hypertree.PublicGraphSigner
+import SphincsSecurity.Proof.Ots.ReferenceEncodingProgram
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalGraphInputs canonicalEncodingInputs frontierSigningRun frontierRoot boundaryEval publicDigestLoop
+
+theorem publicDigestLoop_eq_of_message (parameter : PublicParameter) (f g : QueryImpl HashSpec Id)
+    (hmessage : ∀ root message randomness,
+      f (tweakableHashInput parameter .message (messageDigestPayload root message randomness)) =
+        g (tweakableHashInput parameter .message (messageDigestPayload root message randomness)))
+    (root : Digest) (message : Message) (attempts : Nat) :
+    fixedBoundaryRun parameter f (publicDigestLoop parameter root message attempts) =
+      fixedBoundaryRun parameter g (publicDigestLoop parameter root message attempts) := by
+  have hattempt (randomness : Randomness) :
+      boundaryEval parameter f (publicSignAttempt parameter root message randomness) =
+        boundaryEval parameter g (publicSignAttempt parameter root message randomness) := by
+    simp [publicSignAttempt, messageDigest, oracleHash, boundaryEval, QueryImpl.withTrace_apply, hmessage]
+  induction attempts with
+  | zero => simp only [publicDigestLoop, fixedBoundaryRun_pure]
+  | succ attempts ih =>
+      rw [publicDigestLoop]
+      apply fixedBoundaryRun_bind_congr
+      · exact fixedBoundaryRun_lift_prob_eq parameter f g sampleRandomness
+      · intro randomness
+        apply fixedBoundaryRun_bind_congr
+        · rw [fixedBoundaryRun_lift_hash, fixedBoundaryRun_lift_hash, hattempt]
+        · intro attempt
+          cases attempt with
+          | none => exact ih
+          | some selected => rfl
+
+theorem frontierSignAfterDigest_eq_of_graph (key : SecretKey) (f g : QueryImpl HashSpec Id)
+    (labels : CanonicalGraphLabels) (words : OtsReferenceWords)
+    (hf : canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f = labels)
+    (hg : canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret g = labels)
+    (hselected : referenceTableSelection key f = referenceTableSelection key g)
+    (randomness : Randomness) (index : Index) (leaves : IndexGroup → FtsLeaf) :
+    frontierSignAfterDigest key.parameter f key.ftsSecret words (canonicalGraphFrontier key.otsSecret labels words)
+        randomness index leaves =
+      frontierSignAfterDigest key.parameter g key.ftsSecret words (canonicalGraphFrontier key.otsSecret labels words)
+        randomness index leaves := by
+  let known := CanonicalCoordinate.value key.otsSecret key.ftsSecret labels
+  have haf : PublicAgreement words (fun _ _ _ => False) known
+      (CanonicalCoordinate.value key.otsSecret key.ftsSecret (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f)) := by
+    rw [hf]
+    intro coordinate _
+    rfl
+  have hag : PublicAgreement words (fun _ _ _ => False) known
+      (CanonicalCoordinate.value key.otsSecret key.ftsSecret (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret g)) := by
+    rw [hg]
+    intro coordinate _
+    rfl
+  have hleft := frontierSignAfterDigest_eq_publicPlan key f words _ known haf randomness index leaves
+  have hright := frontierSignAfterDigest_eq_publicPlan key g words _ known hag randomness index leaves
+  rw [hf, hselected] at hleft
+  rw [hg] at hright
+  exact hleft.trans hright.symm
+
+theorem frontierRoot_of_graph (key : SecretKey) (f : QueryImpl HashSpec Id) (labels : CanonicalGraphLabels)
+    (words : OtsReferenceWords) (hlabels : canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f = labels) :
+    frontierRoot key.parameter f words (canonicalGraphFrontier key.otsSecret labels words) = canonicalGraphRoot labels := by
+  have hfrontier : IsSigningFrontier key f words (canonicalGraphFrontier key.otsSecret labels words) := by
+    rw [← hlabels, canonicalGraphLabels_frontier key.parameter key.otsSecret key.ftsSecret f words key.root]
+    exact isSigningFrontier_canonical key f words
+  rw [frontierRoot_eq key f words _ hfrontier, ← canonicalGraphLabels_root key.parameter key.otsSecret key.ftsSecret f, hlabels]
+
+theorem frontierSigningRun_eq_of_graph (key : SecretKey) (f g : QueryImpl HashSpec Id)
+    (labels : CanonicalGraphLabels) (words : OtsReferenceWords)
+    (hf : canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f = labels)
+    (hg : canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret g = labels)
+    (hselected : referenceTableSelection key f = referenceTableSelection key g)
+    (hmessage : ∀ root message randomness,
+      f (tweakableHashInput key.parameter .message (messageDigestPayload root message randomness)) =
+        g (tweakableHashInput key.parameter .message (messageDigestPayload root message randomness)))
+    (root : Digest) (message : Message) :
+    frontierSigningRun key.parameter root f key.ftsSecret words (canonicalGraphFrontier key.otsSecret labels words) message =
+      frontierSigningRun key.parameter root g key.ftsSecret words (canonicalGraphFrontier key.otsSecret labels words) message := by
+  simp only [frontierSigningRun, frontierSigningRecord, publicDigestLoop_eq_of_message key.parameter f g hmessage,
+    frontierSignAfterDigest_eq_of_graph key f g labels words hf hg hselected]
+
+theorem CausalFrontierProgram.game_eq_of_graph (key : SecretKey) (f g : QueryImpl HashSpec Id)
+    (labels : CanonicalGraphLabels) (words : OtsReferenceWords)
+    (hf : canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f = labels)
+    (hg : canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret g = labels)
+    (hselected : referenceTableSelection key f = referenceTableSelection key g)
+    (hmessage : ∀ root message randomness,
+      f (tweakableHashInput key.parameter .message (messageDigestPayload root message randomness)) =
+        g (tweakableHashInput key.parameter .message (messageDigestPayload root message randomness)))
+    (adversary : Adversary) :
+    CausalFrontierProgram.game key.parameter f key.ftsSecret words (canonicalGraphFrontier key.otsSecret labels words) adversary =
+      CausalFrontierProgram.game key.parameter g key.ftsSecret words (canonicalGraphFrontier key.otsSecret labels words) adversary := by
+  let frontier := canonicalGraphFrontier key.otsSecret labels words
+  have hsign (root : Digest) (message : Message) :
+      frontierSigningRun key.parameter root (maskOtsPrefixes key.parameter words f) key.ftsSecret words frontier message =
+        frontierSigningRun key.parameter root (maskOtsPrefixes key.parameter words g) key.ftsSecret words frontier message := by
+    rw [← frontierSigningRun_eq_of_agree key.parameter words f _ (maskOtsPrefixes_agrees key.parameter words f),
+      ← frontierSigningRun_eq_of_agree key.parameter words g _ (maskOtsPrefixes_agrees key.parameter words g)]
+    exact frontierSigningRun_eq_of_graph key f g labels words hf hg hselected hmessage root message
+  have himpl (root : Digest) : CausalFrontierProgram.adversaryImpl key.parameter root f key.ftsSecret words frontier =
+      CausalFrontierProgram.adversaryImpl key.parameter root g key.ftsSecret words frontier := by
+    funext input
+    cases input with
+    | inl input => rfl
+    | inr message => simp only [CausalFrontierProgram.adversaryImpl_signing, hsign]
+  dsimp only [frontier] at himpl
+  rw [CausalFrontierProgram.game, CausalFrontierProgram.game,
+    ← frontierRoot_eq_of_agree key.parameter words f _ (maskOtsPrefixes_agrees key.parameter words f),
+    ← frontierRoot_eq_of_agree key.parameter words g _ (maskOtsPrefixes_agrees key.parameter words g),
+    frontierRoot_of_graph key f labels words hf, frontierRoot_of_graph key g labels words hg]
+  simp only [CausalFrontierProgram.gameRest, CausalFrontierProgram.adversaryRun, himpl]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/ReferenceHypertreeWitness.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/ReferenceHypertreeWitness.lean
new file mode 100644
index 000000000..dfe0afe9c
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/ReferenceHypertreeWitness.lean
@@ -0,0 +1,131 @@
+import SphincsSecurity.Proof.Ots.ReferenceLayerWitness
+import SphincsSecurity.Proof.Reference.VerifierTraceDescent
+namespace SphincsSecurity.Concrete.OtsVerifierWitness
+
+open _root_.OracleComp OracleSpec OtsContactTrace
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] chainWalk sequenceFin canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+variable (f : QueryImpl HashSpec Id) (key : SecretKey) (words : OtsReferenceWords)
+  (messages : EncodingPosition → Digest) (selections : ReferenceFamily)
+
+def LayerException (trace : Trace) : Prop :=
+  EncodingOutputMatch key.parameter words messages selections trace ∨
+    ∃ lay tree leaf, TreeOutputMatch f key.parameter lay tree (key.otsSecret lay tree) trace ∨
+      LeafOutputMatch f key.parameter lay tree leaf (key.otsSecret lay tree leaf) trace ∨
+        ChainException f key.parameter words lay tree leaf (key.otsSecret lay tree leaf) trace
+
+def ReferenceLayerOpening (index : Index) (signature : Signature) (lay : Layer) : Prop :=
+  ∃ selected, selections ⟨lay, treeIndexAt index lay, leafIndexAt index lay⟩ = some selected ∧
+    signature.counter lay = BitVec.ofNat counterBits selected.1.val ∧
+    evalWithAnswerFn f (encode key.parameter lay (treeIndexAt index lay) (leafIndexAt index lay)
+      (evalWithAnswerFn f (layerMessage key index lay)) (signature.counter lay)) = some (words lay (treeIndexAt index lay) (leafIndexAt index lay)) ∧
+    (∀ chain, signature.chainValue lay chain = frontier f key.parameter words lay (treeIndexAt index lay) (leafIndexAt index lay)
+      (key.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)) chain) ∧
+    ∀ level, level < layerHeight lay → signaturePath signature lay level =
+      honestNode f key.parameter lay (treeIndexAt index lay) (key.otsSecret lay (treeIndexAt index lay)) level
+        (Nat.xor ((leafIndexAt index lay).val / 2 ^ level) 1)
+
+theorem layer_frame_reference (index : Index) (signature : Signature) (lay : Layer) (message target leafValue : Digest) (trace : Trace)
+    (hvalid : TargetSum.Valid (words lay (treeIndexAt index lay) (leafIndexAt index lay)))
+    (hmessages : messages ⟨lay, treeIndexAt index lay, leafIndexAt index lay⟩ = evalWithAnswerFn f (layerMessage key index lay))
+    (hclean : ¬LayerException f key words messages selections trace)
+    (hframe : LayerFrame f (recordedCache f trace) key.parameter index signature lay message target leafValue)
+    (hfold : foldValue f key.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) (signaturePath signature lay) leafValue (layerHeight lay) =
+      honestNode f key.parameter lay (treeIndexAt index lay) (key.otsSecret lay (treeIndexAt index lay)) (layerHeight lay) 0) :
+    message = evalWithAnswerFn f (layerMessage key index lay) ∧ ReferenceLayerOpening f key words selections index signature lay := by
+  cases hencode : evalWithAnswerFn f (encode key.parameter lay (treeIndexAt index lay) (leafIndexAt index lay) message (signature.counter lay)) with
+  | none =>
+      have hots := hframe.1
+      simp only [otsLeaf, evalWithAnswerFn_bind, hencode, evalWithAnswerFn_pure, reduceCtorEq] at hots
+  | some candidate =>
+      have h := layer_reference_classification f key.parameter words messages selections lay (treeIndexAt index lay)
+        (key.otsSecret lay (treeIndexAt index lay)) (leafIndexAt index lay) (leafIndexAt_lt index lay) (signaturePath signature lay)
+        message (signature.counter lay) (signature.chainValue lay) candidate leafValue trace hvalid hencode hframe.1 hfold
+        ((recordedCache_run_iff f trace _).mp hframe.2.2.1) ((recordedCache_run_iff f trace _).mp hframe.2.2.2.1)
+      rcases h with ⟨selected, hs, hm, hc, hw, hv, hp⟩ | ht | hl | hc | he
+      · refine ⟨hm.trans hmessages, selected, hs, hc, ?_, hv, hp⟩
+        rw [← hm.trans hmessages, ← hw]
+        exact hencode
+      · exact False.elim (hclean (Or.inr ⟨lay, treeIndexAt index lay, leafIndexAt index lay, Or.inl ht⟩))
+      · exact False.elim (hclean (Or.inr ⟨lay, treeIndexAt index lay, leafIndexAt index lay, Or.inr (Or.inl hl)⟩))
+      · exact False.elim (hclean (Or.inr ⟨lay, treeIndexAt index lay, leafIndexAt index lay, Or.inr (Or.inr hc)⟩))
+      · exact False.elim (hclean (Or.inl he))
+
+theorem hypertree_reference (index : Index) (leaves : IndexGroup → FtsLeaf) (signature : Signature) (trace : Trace)
+    (hvalid : ∀ lay, TargetSum.Valid (words lay (treeIndexAt index lay) (leafIndexAt index lay)))
+    (hmessages : ∀ lay, messages ⟨lay, treeIndexAt index lay, leafIndexAt index lay⟩ = evalWithAnswerFn f (layerMessage key index lay))
+    (hroot : key.root = honestNode f key.parameter topLayer rootTree (key.otsSecret topLayer rootTree) (layerHeight topLayer) 0)
+    (hclean : ¬LayerException f key words messages selections trace)
+    (hverify : evalWithAnswerFn f (verifyLayers key.parameter index signature numLayers (evalWithAnswerFn f (ftsRecover key.parameter index leaves signature.ftsSecret signature.ftsPath))) = some key.root)
+    (hrun : ContainsRun f trace (verifyLayers key.parameter index signature numLayers (evalWithAnswerFn f (ftsRecover key.parameter index leaves signature.ftsSecret signature.ftsPath)))) :
+    (evalWithAnswerFn f (ftsRecover key.parameter index leaves signature.ftsSecret signature.ftsPath)) = honestFtsKey f key.parameter index (key.ftsSecret index) ∧
+      ∀ lay, ReferenceLayerOpening f key words selections index signature lay ∧
+        CachedRun (recordedCache f trace) f (otsLeaf key.parameter lay (treeIndexAt index lay) (leafIndexAt index lay)
+          (evalWithAnswerFn f (layerMessage key index lay)) (signature.counter lay) (signature.chainValue lay)) ∧
+        VerifierLayerMessage f key.parameter index leaves signature lay (evalWithAnswerFn f (layerMessage key index lay)) := by
+  obtain ⟨bottomLeaf, hbottom, middleLeaf, hmiddle, topLeaf, htop⟩ := hypertreeRun_of_verify index signature (evalWithAnswerFn f (ftsRecover key.parameter index leaves signature.ftsSecret signature.ftsPath)) key.root hverify hrun.cached
+  let middleMessage := foldValue f key.parameter bottomLayer (treeIndexAt index bottomLayer) (leafIndexAt index bottomLayer)
+    (signaturePath signature bottomLayer) bottomLeaf (layerHeight bottomLayer)
+  let topMessage := foldValue f key.parameter middleLayer (treeIndexAt index middleLayer) (leafIndexAt index middleLayer)
+    (signaturePath signature middleLayer) middleLeaf (layerHeight middleLayer)
+  have htopFold : foldValue f key.parameter topLayer (treeIndexAt index topLayer) (leafIndexAt index topLayer)
+      (signaturePath signature topLayer) topLeaf (layerHeight topLayer) = key.root := by
+    simpa only [topLayer, verifyLayers_zero_eq, evalWithAnswerFn_pure, Option.some.injEq] using htop.2.1
+  have htree : treeIndexAt index topLayer = rootTree := Fin.ext (treeIndexAt_topLayer index)
+  have htopRoot : foldValue f key.parameter topLayer (treeIndexAt index topLayer) (leafIndexAt index topLayer)
+      (signaturePath signature topLayer) topLeaf (layerHeight topLayer) = honestNode f key.parameter topLayer (treeIndexAt index topLayer)
+        (key.otsSecret topLayer (treeIndexAt index topLayer)) (layerHeight topLayer) 0 := by
+    rw [htopFold, hroot, htree]
+  have ht := layer_frame_reference f key words messages selections index signature topLayer topMessage key.root topLeaf trace
+    (hvalid _) (hmessages _) hclean htop htopRoot
+  have hmRoot := exact_top_message_eq_middle_root f key index index topMessage rfl rfl ht.1.symm
+  have hm := layer_frame_reference f key words messages selections index signature middleLayer middleMessage key.root middleLeaf trace
+    (hvalid _) (hmessages _) hclean hmiddle hmRoot
+  have hbRoot := exact_middle_message_eq_bottom_root f key index index middleMessage rfl rfl hm.1.symm
+  have hb := layer_frame_reference f key words messages selections index signature bottomLayer (evalWithAnswerFn f (ftsRecover key.parameter index leaves signature.ftsSecret signature.ftsPath)) key.root bottomLeaf trace
+    (hvalid _) (hmessages _) hclean hbottom hbRoot
+  refine ⟨exact_bottom_message_eq_fts_key f key index index (evalWithAnswerFn f (ftsRecover key.parameter index leaves signature.ftsSecret signature.ftsPath)) rfl rfl hb.1.symm, ?_⟩
+  have hverifier (position : Layer) (value : Digest)
+      (hp : position = bottomLayer ∧ value = (evalWithAnswerFn f (ftsRecover key.parameter index leaves signature.ftsSecret signature.ftsPath)) ∨
+        position = middleLayer ∧ value = middleMessage ∨ position = topLayer ∧ value = topMessage) :
+      VerifierLayerMessage f key.parameter index leaves signature position value :=
+    ⟨bottomLeaf, hbottom.1, middleLeaf, hmiddle.1, hp⟩
+  have hpack (position : Layer) (value : Digest)
+      (he : value = evalWithAnswerFn f (layerMessage key index position))
+      (ho : ReferenceLayerOpening f key words selections index signature position)
+      (hc : CachedRun (recordedCache f trace) f (otsLeaf key.parameter position (treeIndexAt index position) (leafIndexAt index position)
+        value (signature.counter position) (signature.chainValue position)))
+      (hv : VerifierLayerMessage f key.parameter index leaves signature position value) :
+      ReferenceLayerOpening f key words selections index signature position ∧
+        CachedRun (recordedCache f trace) f (otsLeaf key.parameter position (treeIndexAt index position) (leafIndexAt index position)
+          (evalWithAnswerFn f (layerMessage key index position)) (signature.counter position) (signature.chainValue position)) ∧
+        VerifierLayerMessage f key.parameter index leaves signature position (evalWithAnswerFn f (layerMessage key index position)) := by
+    rw [he] at hc hv
+    exact ⟨ho, hc, hv⟩
+  intro lay
+  fin_cases lay
+  · simpa only [topLayer] using hpack topLayer topMessage ht.1 ht.2 htop.2.2.1
+      (hverifier _ _ (Or.inr (Or.inr ⟨rfl, rfl⟩)))
+  · simpa only [middleLayer] using hpack middleLayer middleMessage hm.1 hm.2 hmiddle.2.2.1
+      (hverifier _ _ (Or.inr (Or.inl ⟨rfl, rfl⟩)))
+  · simpa only [bottomLayer, numLayers] using hpack bottomLayer _ hb.1 hb.2 hbottom.2.2.1
+      (hverifier _ _ (Or.inl ⟨rfl, rfl⟩))
+
+theorem hypertree_classification (index : Index) (leaves : IndexGroup → FtsLeaf) (signature : Signature) (trace : Trace)
+    (hvalid : ∀ lay, TargetSum.Valid (words lay (treeIndexAt index lay) (leafIndexAt index lay)))
+    (hmessages : ∀ lay, messages ⟨lay, treeIndexAt index lay, leafIndexAt index lay⟩ = evalWithAnswerFn f (layerMessage key index lay))
+    (hroot : key.root = honestNode f key.parameter topLayer rootTree (key.otsSecret topLayer rootTree) (layerHeight topLayer) 0)
+    (hverify : evalWithAnswerFn f (verifyLayers key.parameter index signature numLayers (evalWithAnswerFn f (ftsRecover key.parameter index leaves signature.ftsSecret signature.ftsPath))) = some key.root)
+    (hrun : ContainsRun f trace (verifyLayers key.parameter index signature numLayers (evalWithAnswerFn f (ftsRecover key.parameter index leaves signature.ftsSecret signature.ftsPath)))) :
+    ((evalWithAnswerFn f (ftsRecover key.parameter index leaves signature.ftsSecret signature.ftsPath)) = honestFtsKey f key.parameter index (key.ftsSecret index) ∧ ∀ lay, ReferenceLayerOpening f key words selections index signature lay ∧
+        CachedRun (recordedCache f trace) f (otsLeaf key.parameter lay (treeIndexAt index lay) (leafIndexAt index lay)
+          (evalWithAnswerFn f (layerMessage key index lay)) (signature.counter lay) (signature.chainValue lay)) ∧
+        VerifierLayerMessage f key.parameter index leaves signature lay (evalWithAnswerFn f (layerMessage key index lay))) ∨
+      LayerException f key words messages selections trace := by
+  by_cases h : LayerException f key words messages selections trace
+  · exact Or.inr h
+  · exact Or.inl (hypertree_reference f key words messages selections index leaves signature trace hvalid hmessages hroot h hverify hrun)
+
+end SphincsSecurity.Concrete.OtsVerifierWitness
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/RootCache.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/RootCache.lean
new file mode 100644
index 000000000..e19015295
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/RootCache.lean
@@ -0,0 +1,168 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.Position
+import SphincsSecurity.Proof.Scheme.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⟩
+
+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 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
+
+end Concrete
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/Settled.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/Settled.lean
new file mode 100644
index 000000000..c5edd2c81
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/Settled.lean
@@ -0,0 +1,34 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.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]
+
+variable (parameter : PublicParameter)
+  (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+  (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+
+variable {parameter} {otsSecret} {ftsSecret}
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/StructuralMatchAccumulation.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/StructuralMatchAccumulation.lean
new file mode 100644
index 000000000..bf1795064
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/StructuralMatchAccumulation.lean
@@ -0,0 +1,139 @@
+import SphincsSecurity.Proof.Hypertree.StructuralTraceCache
+namespace SphincsSecurity.Concrete.StructuralObservation
+
+open _root_.OracleComp OracleSpec UniformTableCompletion ReferenceStructuralMatch
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] structuralInputs canonicalGraphInputs Finset.univ
+
+theorem entry_active (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels) (words : OtsReferenceWords)
+    (hgraph : canonicalGraphInputs key.parameter ⊆ inputs) (input : HashInput) (answer : HashOutput)
+    (h : Entry key labels words input answer) : Active key inputs labels input := by
+  refine ⟨(mem_structuralInputs key.parameter inputs input).mpr ⟨hgraph h.1, ?_⟩, h.noncanonical⟩
+  obtain ⟨position, _, _, hp, _⟩ := h.2
+  exact ⟨position, hp⟩
+
+theorem newMatch_cell_le (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels) (words : OtsReferenceWords)
+    (history : OtsContactTrace.Trace) (allowed : structuralInputs key.parameter inputs → Finset HashOutput)
+    (hc : TraceConsistent key inputs labels history allowed) (row : structuralInputs key.parameter inputs)
+    (ha : Active key inputs labels row.val) :
+    Pr[fun output => Entry key labels words row.val output ∧ ¬Seen key labels words history | cell (allowed row)] ≤
+      (Fintype.card Digest : ENNReal)⁻¹ * ((if QueryClass.OtherHash key.parameter words (.inr row.val) then 1 else 0 : Nat) : ENNReal) := by
+  refine (_root_.probEvent_mono (fun _ _ h => ⟨h.1, fun hin => h.2 ⟨_, hin, h.1⟩⟩)).trans
+    ((hc.new_reply_probability_le row ha (Entry key labels words row.val)).trans ?_)
+  simpa only [cell, dif_pos Finset.univ_nonempty, PMF.uniformOfFintype] using entry_uniform_other_le key labels words row.val
+
+def QueryNewMatch (key : SecretKey) (labels : CanonicalGraphLabels) (words : OtsReferenceWords) (history : OtsContactTrace.Trace)
+    (input : OracleWorld.Domain) (answer : OracleWorld.Range input) : Prop :=
+  Seen key labels words (history * hashObservationTrace input answer) ∧ ¬Seen key labels words history
+
+theorem queryNewMatch_coin (key : SecretKey) (labels : CanonicalGraphLabels) (words : OtsReferenceWords) (history : OtsContactTrace.Trace)
+    (input : unifSpec.Domain) (answer : unifSpec.Range input) : ¬QueryNewMatch key labels words history (.inl input) answer := by
+  simp only [QueryNewMatch, hashObservationTrace, mul_one, and_not_self, not_false_eq_true]
+
+theorem queryNewMatch_hash (key : SecretKey) (labels : CanonicalGraphLabels) (words : OtsReferenceWords) (history : OtsContactTrace.Trace)
+    (input : HashInput) (answer : HashOutput) :
+    QueryNewMatch key labels words history (.inr input) answer ↔ Entry key labels words input answer ∧ ¬Seen key labels words history := by
+  simp only [QueryNewMatch, hashObservationTrace, seen_mul, seen_of, or_and_right, and_not_self, false_or]
+
+theorem queryNewMatch_le (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels)
+    (hgraph : canonicalGraphInputs key.parameter ⊆ inputs) (outside : NonstructuralRows key.parameter inputs) (words : OtsReferenceWords)
+    (history : OtsContactTrace.Trace) (allowed : structuralInputs key.parameter inputs → Finset HashOutput)
+    (hc : TraceConsistent key inputs labels history allowed) (input : OracleWorld.Domain) :
+    Pr[fun result => QueryNewMatch key labels words history input result.1 | (lazyWorldImpl key inputs labels outside input).run allowed] ≤
+      (Fintype.card Digest : ENNReal)⁻¹ * ((if QueryClass.OtherHash key.parameter words input then 1 else 0 : Nat) : ENNReal) := by
+  cases input with
+  | inl input =>
+      have hz : Pr[fun result => QueryNewMatch key labels words history (.inl input) result.1 |
+          (lazyWorldImpl key inputs labels outside (.inl input)).run allowed] = 0 :=
+        probEvent_eq_zero fun result _ => queryNewMatch_coin _ _ _ _ _ result.1
+      rw [hz]
+      exact bot_le
+  | inr input =>
+      by_cases ha : Active key inputs labels input
+      · simp only [lazyWorldImpl, QueryImpl.compose, translate, dif_pos ha, simulateQ_spec_query,
+          UniformTableObservation.lazyImpl, StateT.run_mk, probEvent_map, Function.comp_def, queryNewMatch_hash]
+        exact newMatch_cell_le key inputs labels words history allowed hc ⟨input, ha.1⟩ ha
+      · have hz : Pr[fun result => QueryNewMatch key labels words history (.inr input) result.1 |
+            (lazyWorldImpl key inputs labels outside (.inr input)).run allowed] = 0 := by
+          apply probEvent_eq_zero
+          intro result _ hm
+          exact ha (entry_active key inputs labels words hgraph input result.1 ((queryNewMatch_hash _ _ _ _ _ _).mp hm).1)
+        rw [hz]
+        exact bot_le
+
+noncomputable def otherCalls (parameter : PublicParameter) (words : OtsReferenceWords) (trace : OtsContactTrace.Trace) : Nat :=
+  QueryCap.calls (QueryClass.OtherHash parameter words) (trace.toList.map fun entry => .inr entry.1)
+
+theorem otherCalls_one (parameter : PublicParameter) (words : OtsReferenceWords) : otherCalls parameter words 1 = 0 := rfl
+
+theorem otherCalls_step (parameter : PublicParameter) (words : OtsReferenceWords) (input : OracleWorld.Domain)
+    (answer : OracleWorld.Range input) (tail : OtsContactTrace.Trace) :
+    otherCalls parameter words (hashObservationTrace input answer * tail) =
+      (if QueryClass.OtherHash parameter words input then 1 else 0) + otherCalls parameter words tail := by
+  cases input with
+  | inl input =>
+      simp only [hashObservationTrace, one_mul, QueryClass.OtherHash, CausalFrontierProgram.NonmessageHash, false_and, if_false, Nat.zero_add]
+  | inr input =>
+      simp only [otherCalls, hashObservationTrace, FreeMonoid.toList_mul, FreeMonoid.toList_of,
+        List.singleton_append, List.map_cons, QueryCap.calls_cons]
+
+theorem match_query_potential_le (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels)
+    (hgraph : canonicalGraphInputs key.parameter ⊆ inputs) (outside : NonstructuralRows key.parameter inputs) (words : OtsReferenceWords)
+    (history : OtsContactTrace.Trace) (allowed : structuralInputs key.parameter inputs → Finset HashOutput)
+    (hc : TraceConsistent key inputs labels history allowed) (input : OracleWorld.Domain) :
+    (∑' result, Pr[= result | (lazyWorldImpl key inputs labels outside input).run allowed] *
+      (if Seen key labels words (history * hashObservationTrace input result.1) then 1 else 0 : ENNReal)) ≤
+      (if Seen key labels words history then 1 else 0 : ENNReal) +
+        (Fintype.card Digest : ENNReal)⁻¹ * ((if QueryClass.OtherHash key.parameter words input then 1 else 0 : Nat) : ENNReal) := by
+  by_cases hs : Seen key labels words history
+  · have hnext : ∀ answer, Seen key labels words (history * hashObservationTrace input answer) :=
+      fun _ => (seen_mul _ _ _ _ _).mpr (Or.inl hs)
+    simp only [if_pos hs, if_pos (hnext _), mul_one]
+    exact le_add_of_le_left tsum_probOutput_le_one
+  · simpa only [QueryNewMatch, hs, not_false_eq_true, and_true, if_false, zero_add,
+      probEvent_eq_tsum_ite, mul_ite, mul_one, mul_zero] using queryNewMatch_le key inputs labels hgraph outside words history allowed hc input
+
+theorem match_lazyRun_le {Result : Type} (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels)
+    (hgraph : canonicalGraphInputs key.parameter ⊆ inputs) (outside : NonstructuralRows key.parameter inputs) (words : OtsReferenceWords)
+    (computation : OracleComp OracleWorld Result) (history : OtsContactTrace.Trace)
+    (allowed : structuralInputs key.parameter inputs → Finset HashOutput) (hc : TraceConsistent key inputs labels history allowed)
+    (ha : ∀ row, (allowed row).Nonempty) :
+    Pr[fun result => Seen key labels words (history * result.1.2) |
+      lazyRun key inputs labels outside (QueryPause.traced hashObservationTrace computation) allowed] ≤
+      (if Seen key labels words history then 1 else 0 : ENNReal) + (Fintype.card Digest : ENNReal)⁻¹ * ∑' result,
+        Pr[= result | lazyRun key inputs labels outside (QueryPause.traced hashObservationTrace computation) allowed] *
+          (otherCalls key.parameter words result.1.2 : ENNReal) := by
+  suffices h : (∑' result, Pr[= result | lazyRun key inputs labels outside (QueryPause.traced hashObservationTrace computation) allowed] *
+      (if Seen key labels words (history * result.1.2) then 1 else 0 : ENNReal)) ≤
+      (if Seen key labels words history then 1 else 0 : ENNReal) + (Fintype.card Digest : ENNReal)⁻¹ * ∑' result,
+        Pr[= result | lazyRun key inputs labels outside (QueryPause.traced hashObservationTrace computation) allowed] *
+          (otherCalls key.parameter words result.1.2 : ENNReal) by
+    simpa only [mul_ite, mul_one, mul_zero, ← probEvent_eq_tsum_ite] using h
+  simp only [lazyRun_eq_simulate]
+  apply QueryPause.traced_spmf_potential_le hashObservationTrace (lazyWorldImpl key inputs labels outside)
+    (fun history allowed => TraceConsistent key inputs labels history allowed ∧ ∀ row, (allowed row).Nonempty)
+    _ _ (fun history _ => if Seen key labels words history then 1 else 0)
+    _ (otherCalls key.parameter words) _ (otherCalls_one key.parameter words) (otherCalls_step key.parameter words)
+    _ computation history allowed ⟨hc, ha⟩
+  · intro history allowed hi input result hr
+    exact ⟨lazyWorldImpl_traceConsistent key inputs labels outside allowed history hi.1 input result hr,
+      UniformTableObservation.lazyRun_nonempty (auxiliary key inputs labels outside) (translate key inputs labels input) allowed hi.2 result hr⟩
+  · intro computation history allowed hi
+    rw [← lazyRun_eq_simulate]
+    exact probFailure_eq_zero' (lazyRun_neverFail key inputs labels outside _ allowed hi.2)
+  · intro history allowed hi input
+    exact match_query_potential_le key inputs labels hgraph outside words history allowed hi.1 input
+
+theorem match_initial_lazyRun_le {Result : Type} (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels)
+    (hgraph : canonicalGraphInputs key.parameter ⊆ inputs) (outside : NonstructuralRows key.parameter inputs) (words : OtsReferenceWords)
+    (computation : OracleComp OracleWorld Result) :
+    Pr[fun result => Seen key labels words result.1.2 |
+      lazyRun key inputs labels outside (QueryPause.traced hashObservationTrace computation) (fun _ => Finset.univ)] ≤
+      (Fintype.card Digest : ENNReal)⁻¹ * ∑' result,
+        Pr[= result | lazyRun key inputs labels outside (QueryPause.traced hashObservationTrace computation) (fun _ => Finset.univ)] *
+          (otherCalls key.parameter words result.1.2 : ENNReal) := by
+  simpa only [one_mul, if_neg (seen_one key labels words), zero_add] using
+    match_lazyRun_le key inputs labels hgraph outside words computation 1 _ (traceConsistent_one key inputs labels) (fun _ => Finset.univ_nonempty)
+
+end SphincsSecurity.Concrete.StructuralObservation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/StructuralMatchBound.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/StructuralMatchBound.lean
new file mode 100644
index 000000000..caaafd89d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/StructuralMatchBound.lean
@@ -0,0 +1,140 @@
+import SphincsSecurity.Proof.Hypertree.StructuralMatchAccumulation
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphInputs canonicalEncodingInputs canonicalGraphGameInputs structuralInputs Finset.univ
+
+theorem structuralLazy_contact_match_le (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels)
+    (hgraph : canonicalGraphInputs key.parameter ⊆ inputs) (outside : NonstructuralRows key.parameter inputs)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) (computation : OracleComp OracleWorld (Bool × SigningBoundaryTrace)) :
+    Pr[fun result => ReferenceStructuralMatch.Seen key labels words (result.1.before * result.1.after) |
+      StructuralObservation.lazyRun key inputs labels outside (contactObserver key.parameter words frontier computation) (fun _ => Finset.univ)] ≤
+      (Fintype.card Digest : ENNReal)⁻¹ * ∑' result,
+        Pr[= result | StructuralObservation.lazyRun key inputs labels outside
+          (contactObserver key.parameter words frontier computation) (fun _ => Finset.univ)] *
+            (StructuralObservation.otherCalls key.parameter words (result.1.before * result.1.after) : ENNReal) := by
+  have h := StructuralObservation.match_initial_lazyRun_le key inputs labels hgraph outside words computation
+  have htrace : (fun result => ((result.1.output, result.1.before * result.1.after), result.2)) <$>
+      StructuralObservation.lazyRun key inputs labels outside (contactObserver key.parameter words frontier computation) (fun _ => Finset.univ) =
+        StructuralObservation.lazyRun key inputs labels outside (QueryPause.traced hashObservationTrace computation) (fun _ => Finset.univ) := by
+    rw [← StructuralObservation.lazyRun_map (f := fun result : ContactResult => (result.output, result.before * result.after)), contactObserver_trace]
+  rw [← htrace, probEvent_map, tsum_probOutput_map_mul] at h
+  exact h
+
+private theorem weighted_bound {Value : Type} (law : SPMF Value) (left right : Value → ENNReal) (rate : ENNReal)
+    (h : ∀ value, left value ≤ rate * right value) :
+    (∑' value, Pr[= value | law] * left value) ≤ rate * ∑' value, Pr[= value | law] * right value := by
+  calc
+    _ ≤ ∑' value, Pr[= value | law] * (rate * right value) := ENNReal.tsum_le_tsum fun value => mul_le_mul' le_rfl (h value)
+    _ = _ := by simp only [mul_left_comm _ rate, ENNReal.tsum_mul_left]
+
+theorem referenceGraphContextRest_match_le (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (hgraph : canonicalGraphInputs key.parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    Pr[fun result => ReferenceStructuralMatch.Seen key result.1 (referenceFamilyWords result.2.1 dummy)
+      (result.2.2.before * result.2.2.after) | referenceGraphContextRest contactObserver key inputs hencoding dummy adversary] ≤
+      (Fintype.card Digest : ENNReal)⁻¹ * ∑' result,
+        Pr[= result | referenceGraphContextRest contactObserver key inputs hencoding dummy adversary] *
+          (StructuralObservation.otherCalls key.parameter (referenceFamilyWords result.2.1 dummy) (result.2.2.before * result.2.2.after) : ENNReal) := by
+  rw [StructuralObservation.referenceGraphContextRest_lazy contactObserver key inputs hencoding hgraph dummy adversary]
+  simp only [probEvent_bind_eq_tsum, probEvent_pure, tsum_probOutput_bind_mul, tsum_probOutput_map_mul, tsum_probOutput_pure_mul]
+  apply weighted_bound
+  intro labels
+  apply weighted_bound
+  intro outside
+  simpa only [probEvent_pure, mul_ite, mul_one, mul_zero, probEvent_eq_tsum_ite] using
+    structuralLazy_contact_match_le key inputs labels hgraph outside
+      (referenceFamilyWords (referenceTableSelection key (structuralAnswer key inputs labels outside (fun _ => 0))) dummy) _
+      (structuralProgram key inputs labels outside _ adversary)
+
+theorem referenceGraphContextGame_match_le (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    Pr[fun result => ReferenceStructuralMatch.Seen result.1 result.2.1 (referenceFamilyWords result.2.2.1 dummy)
+      (result.2.2.2.before * result.2.2.2.after) | referenceGraphContextGame contactObserver inputs hencoding dummy adversary] ≤
+      (Fintype.card Digest : ENNReal)⁻¹ * ∑' result,
+        Pr[= result | referenceGraphContextGame contactObserver inputs hencoding dummy adversary] *
+          (StructuralObservation.otherCalls result.1.parameter (referenceFamilyWords result.2.2.1 dummy)
+            (result.2.2.2.before * result.2.2.2.after) : ENNReal) := by
+  simp only [referenceGraphContextGame, probEvent_bind_eq_tsum, probEvent_pure, tsum_probOutput_bind_mul, tsum_probOutput_pure_mul]
+  apply weighted_bound
+  intro parameter
+  apply weighted_bound
+  intro otsSecret
+  apply weighted_bound
+  intro ftsSecret
+  simpa only [probEvent_pure, mul_ite, mul_one, mul_zero, probEvent_eq_tsum_ite] using
+    referenceGraphContextRest_match_le ⟨parameter, 0, otsSecret, ftsSecret⟩ inputs (hencoding parameter) (hgraph parameter) dummy adversary
+
+theorem contactObserver_otherCalls (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (computation : OracleComp OracleWorld (Bool × SigningBoundaryTrace)) :
+    (fun result : ContactResult => (result.output, StructuralObservation.otherCalls parameter words (result.before * result.after))) <$>
+      contactObserver parameter words frontier computation = QueryCap.counted (QueryClass.OtherHash parameter words) computation := by
+  have h := congrArg (Functor.map (fun result => (result.1, StructuralObservation.otherCalls parameter words result.2)))
+    (contactObserver_trace parameter words frontier computation)
+  rw [Functor.map_map] at h
+  exact h.trans (QueryPause.traced_counted hashObservationTrace (QueryClass.OtherHash parameter words)
+    (StructuralObservation.otherCalls parameter words) (StructuralObservation.otherCalls_one parameter words)
+    (StructuralObservation.otherCalls_step parameter words) computation)
+
+theorem referenceContactRest_otherCalls (key : SecretKey) (oracle : QueryImpl HashSpec Id) (labels : CanonicalGraphLabels)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (fun result : ContactResult => (result.output,
+      StructuralObservation.otherCalls key.parameter (referenceFamilyWords selections dummy) (result.before * result.after))) <$>
+        referenceInstrumentedRest contactObserver key oracle labels selections dummy adversary =
+      (fun result => (result.1, QueryCap.calls (QueryClass.OtherHash key.parameter (referenceFamilyWords selections dummy)) result.2)) <$>
+        referenceRecordedRest key oracle labels selections dummy adversary := by
+  rw [referenceInstrumentedRest, referenceRecordedRest, ← simulateQ_map, ← simulateQ_map,
+    contactObserver_otherCalls, QueryCap.recorded_counted]
+
+theorem referenceContactGame_otherCalls (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (fun result : InstrumentedResult ContactResult => (result.1, result.2.1, result.2.2.output,
+      StructuralObservation.otherCalls result.1 (referenceFamilyWords result.2.1 dummy) (result.2.2.before * result.2.2.after))) <$>
+        referenceContactGame inputs hencoding dummy adversary =
+      (fun result : ReferenceRecordedResult => (result.1, result.2.1, result.2.2.1, result.otherCalls dummy)) <$>
+        referenceRecordedGame inputs hencoding dummy adversary := by
+  unfold referenceContactGame referenceInstrumentedGame referenceRecordedGame
+  simp only [map_bind, map_pure, ReferenceRecordedResult.otherCalls]
+  apply congrArg (𝒟[sampleParameter] >>= ·)
+  funext parameter
+  apply congrArg (𝒟[sampleOtsSecrets] >>= ·)
+  funext otsSecret
+  apply congrArg (𝒟[sampleFtsSecrets] >>= ·)
+  funext ftsSecret
+  apply congrArg (𝒟[referenceFamilyOracleSample _ inputs (hencoding parameter)] >>= ·)
+  funext reference
+  have h := congrArg (fun law => (fun result => (parameter, reference.1, result.1, result.2)) <$> 𝒟[law])
+    (referenceContactRest_otherCalls ⟨parameter, 0, otsSecret, ftsSecret⟩ (finiteHashAnswer ∅ inputs reference.2)
+      (canonicalGraphLabels parameter otsSecret ftsSecret (finiteHashAnswer ∅ inputs reference.2)) reference.1 dummy adversary)
+  simpa only [← bind_pure_comp, evalDist_bind, evalDist_pure, bind_assoc, pure_bind] using h
+
+theorem referenceGraphContextGame_expected_otherCalls (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (∑' result, Pr[= result | referenceGraphContextGame contactObserver inputs hencoding dummy adversary] *
+      (StructuralObservation.otherCalls result.1.parameter (referenceFamilyWords result.2.2.1 dummy)
+        (result.2.2.2.before * result.2.2.2.after) : ENNReal)) =
+      ∑' result, Pr[= result | referenceRecordedGame inputs hencoding dummy adversary] * (result.otherCalls dummy : ENNReal) := by
+  have he := congrArg (fun law : SPMF (InstrumentedResult ContactResult) => ∑' result, Pr[= result | law] *
+    (StructuralObservation.otherCalls result.1 (referenceFamilyWords result.2.1 dummy) (result.2.2.before * result.2.2.after) : ENNReal))
+      (referenceGraphContextGame_erased contactObserver inputs hencoding dummy adversary)
+  rw [tsum_probOutput_map_mul] at he
+  have hc := congrArg (fun law : SPMF (PublicParameter × ReferenceFamily × (Bool × SigningBoundaryTrace) × Nat) =>
+    ∑' result, Pr[= result | law] * (result.2.2.2 : ENNReal)) (referenceContactGame_otherCalls inputs hencoding dummy adversary)
+  simp only [tsum_probOutput_map_mul] at hc
+  exact he.trans hc
+
+theorem referenceGraphContextGame_match_le_otherCost (dummy : OtsReferenceWords) (adversary : Adversary) :
+    Pr[fun result => ReferenceStructuralMatch.Seen result.1 result.2.1 (referenceFamilyWords result.2.2.1 dummy)
+      (result.2.2.2.before * result.2.2.2.after) |
+        referenceGraphContextGame contactObserver (canonicalGraphGameInputs adversary)
+          (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] ≤
+      (Fintype.card Digest : ENNReal)⁻¹ * ∑' result,
+        Pr[= result | referenceRecordedGame (canonicalGraphGameInputs adversary)
+          (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] * (result.otherCalls dummy : ENNReal) := by
+  rw [← referenceGraphContextGame_expected_otherCalls]
+  exact referenceGraphContextGame_match_le _ _ (canonicalGraphInputs_subset_gameInputs adversary) dummy adversary
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/StructuralMatchKernel.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/StructuralMatchKernel.lean
new file mode 100644
index 000000000..701e3bed0
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/StructuralMatchKernel.lean
@@ -0,0 +1,101 @@
+import SphincsSecurity.Proof.Hypertree.ReferenceGraphContext
+import SphincsSecurity.Proof.Reference.ReferencePrimitiveWitness
+namespace SphincsSecurity.Concrete.ReferenceStructuralMatch
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting OtsContactTrace
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphInputs canonicalEncodingInputs canonicalPayloadInputs instFintypePosition
+
+def Entry (key : SecretKey) (labels : CanonicalGraphLabels) (words : OtsReferenceWords)
+    (input : HashInput) (answer : HashOutput) : Prop :=
+  input ∈ canonicalGraphInputs key.parameter ∧ ∃ position, ReferencePrimitiveWitness.AboveFrontier words position ∧ position.TreeBound ∧
+    AtPosition key.parameter input position ∧ input ≠ canonicalGraphInput key.parameter key.otsSecret key.ftsSecret position labels ∧
+      truncateHash answer = truncateHash (labels position)
+
+def Seen (key : SecretKey) (labels : CanonicalGraphLabels) (words : OtsReferenceWords) (trace : Trace) : Prop :=
+  ∃ entry ∈ trace.toList, Entry key labels words entry.1 entry.2
+
+theorem seen_one (key : SecretKey) (labels : CanonicalGraphLabels) (words : OtsReferenceWords) :
+    ¬Seen key labels words 1 := by simp [Seen]
+
+theorem seen_of (key : SecretKey) (labels : CanonicalGraphLabels) (words : OtsReferenceWords) (entry : HashInput × HashOutput) :
+    Seen key labels words (FreeMonoid.of entry) ↔ Entry key labels words entry.1 entry.2 := by simp [Seen]
+
+theorem seen_mul (key : SecretKey) (labels : CanonicalGraphLabels) (words : OtsReferenceWords) (before after : Trace) :
+    Seen key labels words (before * after) ↔ Seen key labels words before ∨ Seen key labels words after := by
+  simp only [Seen, FreeMonoid.toList_mul, List.mem_append, or_and_right, exists_or]
+
+theorem source_match (key : SecretKey) (f : QueryImpl HashSpec Id) (words : OtsReferenceWords) (trace : Trace)
+    (h : ReferencePrimitiveWitness.StructuralMatch key f words trace) :
+    Seen key (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f) words trace := by
+  obtain ⟨position, habove, hbound, payload, hpayload, hrow, hne, hvalue⟩ := h
+  have hcanonical := canonicalGraphInput_eq_honest key.parameter key.otsSecret key.ftsSecret f position
+    (hbound.valid position) (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f)
+    (fun child hc => congrArg truncateHash
+      (canonicalGraphLabels_eq_honest key.parameter key.otsSecret key.ftsSecret f child (hbound.child hc)))
+  refine ⟨_, hrow, graphInput_mem_of_payload key.parameter position payload hpayload, position, habove, hbound, ⟨_, rfl⟩, ?_, ?_⟩
+  · intro heq
+    rw [hcanonical] at heq
+    exact hne (tweakableHashInput_injective key.parameter position.domain_inRange position.domain_inRange heq).2
+  · rw [canonicalGraphLabels_eq_honest key.parameter key.otsSecret key.ftsSecret f position hbound]
+    exact hvalue
+
+theorem Entry.noncanonical {key : SecretKey} {labels : CanonicalGraphLabels} {words : OtsReferenceWords}
+    {input : HashInput} {answer : HashOutput} (h : Entry key labels words input answer) :
+    ∀ position, input ≠ canonicalGraphInput key.parameter key.otsSecret key.ftsSecret position labels := by
+  obtain ⟨_, position, _, _, hp, hn, _⟩ := h
+  exact noncanonical_at key.parameter key.otsSecret key.ftsSecret labels input position hp hn
+
+theorem Entry.otherHash {key : SecretKey} {labels : CanonicalGraphLabels} {words : OtsReferenceWords}
+    {input : HashInput} {answer : HashOutput} (h : Entry key labels words input answer) :
+    QueryClass.OtherHash key.parameter words (.inr input) := by
+  obtain ⟨_, position, habove, _, hp, _, _⟩ := h
+  refine ⟨?_, ?_, ?_⟩
+  · rintro ⟨payload, heq⟩
+    have hd := (decodePosition_some_iff key.parameter input position).mpr hp
+    rw [← heq, decodePosition_message] at hd
+    contradiction
+  · rintro ⟨encoding, he⟩
+    exact he.not_atPosition position hp
+  · intro address hs
+    obtain ⟨query, hquery⟩ := Option.ne_none_iff_exists'.mp hs
+    have hi := ((OtsPrefix.atAddress key.parameter words address).parse_some_iff input query).mp hquery
+    have heq := atPosition_unique key.parameter hp
+      (show AtPosition key.parameter input (.chain address.1 address.2.1 address.2.2.1 address.2.2.2
+        ((OtsPrefix.atAddress key.parameter words address).step query.1)) from ⟨_, hi⟩)
+    subst position
+    change (words address.1 address.2.1 address.2.2.1 address.2.2.2).val ≤ query.1.val at habove
+    exact Nat.not_lt_of_ge habove query.1.isLt
+
+theorem entry_uniform_le (key : SecretKey) (labels : CanonicalGraphLabels) (words : OtsReferenceWords) (input : HashInput) :
+    Pr[Entry key labels words input | (liftM (PMF.uniformOfFintype HashOutput) : SPMF HashOutput)] ≤
+      (Fintype.card Digest : ENNReal)⁻¹ := by
+  by_cases hp : ∃ position, AtPosition key.parameter input position
+  · obtain ⟨position, hp⟩ := hp
+    calc
+      _ ≤ Pr[fun answer => truncateHash answer = truncateHash (labels position) |
+          (liftM (PMF.uniformOfFintype HashOutput) : SPMF HashOutput)] := by
+        apply _root_.probEvent_mono
+        rintro answer _ ⟨_, other, _, _, ho, _, he⟩
+        obtain rfl := atPosition_unique key.parameter ho hp
+        exact he
+      _ = _ := HiddenLabelProbe.prob_truncate_eq _
+  · have hz : Pr[Entry key labels words input | (liftM (PMF.uniformOfFintype HashOutput) : SPMF HashOutput)] = 0 := by
+      apply probEvent_eq_zero
+      rintro answer _ ⟨_, position, _, _, hi, _⟩
+      exact hp ⟨position, hi⟩
+    rw [hz]
+    exact bot_le
+
+theorem entry_uniform_other_le (key : SecretKey) (labels : CanonicalGraphLabels) (words : OtsReferenceWords) (input : HashInput) :
+    Pr[Entry key labels words input | (liftM (PMF.uniformOfFintype HashOutput) : SPMF HashOutput)] ≤
+      (Fintype.card Digest : ENNReal)⁻¹ * ((if QueryClass.OtherHash key.parameter words (.inr input) then 1 else 0 : Nat) : ENNReal) := by
+  by_cases ho : QueryClass.OtherHash key.parameter words (.inr input)
+  · simpa only [if_pos ho, Nat.cast_one, mul_one] using entry_uniform_le key labels words input
+  · have hz : Pr[Entry key labels words input | (liftM (PMF.uniformOfFintype HashOutput) : SPMF HashOutput)] = 0 :=
+      probEvent_eq_zero fun _ _ h => ho h.otherHash
+    rw [hz]
+    exact bot_le
+
+end SphincsSecurity.Concrete.ReferenceStructuralMatch
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/StructuralOracleObservation.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/StructuralOracleObservation.lean
new file mode 100644
index 000000000..6ec9b0835
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/StructuralOracleObservation.lean
@@ -0,0 +1,115 @@
+import SphincsSecurity.Proof.Hypertree.StructuralMatchKernel
+namespace SphincsSecurity.Concrete.StructuralObservation
+
+open _root_.OracleComp OracleSpec UniformTableCompletion
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphInputs canonicalEncodingInputs structuralInputs Finset.univ
+
+def Active (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels) (input : HashInput) : Prop :=
+  input ∈ structuralInputs key.parameter inputs ∧
+    ∀ position, input ≠ canonicalGraphInput key.parameter key.otsSecret key.ftsSecret position labels
+
+theorem answer_active (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels)
+    (outside : NonstructuralRows key.parameter inputs) (rows : structuralInputs key.parameter inputs → HashOutput)
+    (input : HashInput) (ha : Active key inputs labels input) :
+    structuralAnswer key inputs labels outside rows input = rows ⟨input, ha.1⟩ := by
+  rw [structuralAnswer, programmedHash_other _ _ _ _ _ input ha.2,
+    finiteHashAnswer_none ∅ inputs _ input (structuralInputs_subset key.parameter inputs ha.1) (by simp)]
+  exact UniformTableSplit.join_embed (structuralInputCell key.parameter inputs) (structuralInputCell_injective key.parameter inputs)
+    rows outside ⟨input, ha.1⟩
+
+theorem answer_inactive (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels)
+    (outside : NonstructuralRows key.parameter inputs) (left right : structuralInputs key.parameter inputs → HashOutput)
+    (input : HashInput) (ha : ¬Active key inputs labels input) :
+    structuralAnswer key inputs labels outside left input = structuralAnswer key inputs labels outside right input := by
+  by_cases hc : ∃ position, input = canonicalGraphInput key.parameter key.otsSecret key.ftsSecret position labels
+  · obtain ⟨position, rfl⟩ := hc
+    simp only [structuralAnswer, programmedHash_at]
+  · have hn : ∀ position, input ≠ canonicalGraphInput key.parameter key.otsSecret key.ftsSecret position labels :=
+      fun position he => hc ⟨position, he⟩
+    have hout : input ∉ structuralInputs key.parameter inputs := fun hi => ha ⟨hi, hn⟩
+    rw [structuralAnswer, structuralAnswer, programmedHash_other _ _ _ _ _ input hn,
+      programmedHash_other _ _ _ _ _ input hn]
+    exact joinStructuralTable_agrees_outside key.parameter inputs left right outside input hout
+
+abbrev World (key : SecretKey) (inputs : Finset HashInput) :=
+  OracleWorld + UniformTableObservation.TableSpec (structuralInputs key.parameter inputs) HashOutput
+
+noncomputable def translate (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels) :
+    QueryImpl OracleWorld (OracleComp (World key inputs))
+  | .inl input => liftM ((World key inputs).query (.inl (.inl input)))
+  | .inr input =>
+      if h : Active key inputs labels input then liftM ((World key inputs).query (.inr ⟨input, h.1⟩))
+      else liftM ((World key inputs).query (.inl (.inr input)))
+
+noncomputable def auxiliary (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels)
+    (outside : NonstructuralRows key.parameter inputs) : QueryImpl OracleWorld SPMF :=
+  fun input => 𝒟[fixedHashWorld (structuralAnswer key inputs labels outside (fun _ => 0)) input]
+
+theorem fixed_translate (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels)
+    (outside : NonstructuralRows key.parameter inputs) (rows : structuralInputs key.parameter inputs → HashOutput)
+    (input : OracleWorld.Domain) :
+    simulateQ (UniformTableObservation.fixedImpl (auxiliary key inputs labels outside) rows) (translate key inputs labels input) =
+      𝒟[fixedHashWorld (structuralAnswer key inputs labels outside rows) input] := by
+  cases input with
+  | inl input =>
+      simp only [translate, simulateQ_spec_query, UniformTableObservation.fixedImpl, auxiliary, fixedHashWorld]
+  | inr input =>
+      by_cases ha : Active key inputs labels input
+      · simp only [translate, dif_pos ha, simulateQ_spec_query, UniformTableObservation.fixedImpl,
+          fixedHashWorld, evalDist_pure, answer_active key inputs labels outside rows input ha]
+      · simp only [translate, dif_neg ha, simulateQ_spec_query, UniformTableObservation.fixedImpl, auxiliary,
+          fixedHashWorld, evalDist_pure, answer_inactive key inputs labels outside rows (fun _ => 0) input ha]
+
+theorem fixed_run {Result : Type} (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels)
+    (outside : NonstructuralRows key.parameter inputs) (rows : structuralInputs key.parameter inputs → HashOutput)
+    (computation : OracleComp OracleWorld Result) :
+    simulateQ (UniformTableObservation.fixedImpl (auxiliary key inputs labels outside) rows)
+        (simulateQ (translate key inputs labels) computation) =
+      𝒟[simulateQ (fixedHashWorld (structuralAnswer key inputs labels outside rows)) computation] := by
+  induction computation using OracleComp.inductionOn with
+  | pure result => simp only [simulateQ_pure, evalDist_pure]
+  | query_bind input next ih =>
+      simp only [simulateQ_bind, simulateQ_spec_query, evalDist_bind, ih, fixed_translate]
+
+noncomputable def lazyRun {Result : Type} (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels)
+    (outside : NonstructuralRows key.parameter inputs) (computation : OracleComp OracleWorld Result)
+    (allowed : structuralInputs key.parameter inputs → Finset HashOutput) :
+    SPMF (Result × (structuralInputs key.parameter inputs → Finset HashOutput)) :=
+  UniformTableObservation.lazyRun (auxiliary key inputs labels outside) (simulateQ (translate key inputs labels) computation) allowed
+
+theorem lazyRun_original {Result : Type} (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels)
+    (outside : NonstructuralRows key.parameter inputs) (computation : OracleComp OracleWorld Result)
+    (allowed : structuralInputs key.parameter inputs → Finset HashOutput) (ha : ∀ cell, (allowed cell).Nonempty) :
+    (complete allowed >>= fun rows => 𝒟[simulateQ (fixedHashWorld (structuralAnswer key inputs labels outside rows)) computation]) =
+      Prod.fst <$> lazyRun key inputs labels outside computation allowed := by
+  have h := UniformTableObservation.run_marginal (auxiliary key inputs labels outside)
+    (simulateQ (translate key inputs labels) computation) allowed ha
+  simpa only [fixed_run, lazyRun] using h
+
+theorem uniform_rows_complete (parameter : PublicParameter) (inputs : Finset HashInput) :
+    𝒟[PMF.uniformOfFintype (structuralInputs parameter inputs → HashOutput)] =
+      complete (fun _ : structuralInputs parameter inputs => (Finset.univ : Finset HashOutput)) := by
+  rw [complete, dif_pos (fun _ => Finset.univ_nonempty), uniformTable_univ]
+
+theorem referenceGraphContextRest_lazy {Result : Type} (observer : FrontierObserver Result)
+    (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+    (hgraph : canonicalGraphInputs key.parameter ⊆ inputs) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    referenceGraphContextRest observer key inputs hencoding dummy adversary = (do
+      let labels ← 𝒟[PMF.uniformOfFintype CanonicalGraphLabels]
+      let outside ← 𝒟[PMF.uniformOfFintype (NonstructuralRows key.parameter inputs)]
+      let selections := referenceTableSelection key (structuralAnswer key inputs labels outside (fun _ => 0))
+      let words := referenceFamilyWords selections dummy
+      let result ← Prod.fst <$> lazyRun key inputs labels outside
+        (observer key.parameter words (canonicalGraphFrontier key.otsSecret labels words)
+          (structuralProgram key inputs labels outside words adversary)) (fun _ => Finset.univ)
+      pure (labels, selections, result)) := by
+  rw [referenceGraphContextRest_conditioned observer key inputs hencoding hgraph dummy adversary]
+  apply congrArg (𝒟[PMF.uniformOfFintype CanonicalGraphLabels] >>= ·)
+  funext labels
+  apply congrArg (𝒟[PMF.uniformOfFintype (NonstructuralRows key.parameter inputs)] >>= ·)
+  funext outside
+  rw [uniform_rows_complete, ← bind_assoc, lazyRun_original _ _ _ _ _ _ (fun _ => Finset.univ_nonempty)]
+
+end SphincsSecurity.Concrete.StructuralObservation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/StructuralOracleSplit.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/StructuralOracleSplit.lean
new file mode 100644
index 000000000..da55e7e8e
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/StructuralOracleSplit.lean
@@ -0,0 +1,107 @@
+import SphincsSecurity.Proof.Hypertree.ReferenceGraphProgram
+import SphincsSecurity.Proof.Reference.ReferenceAuxiliarySigning
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition Finset.univ
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def structuralInputs (parameter : PublicParameter) (inputs : Finset HashInput) : Finset HashInput :=
+  inputs.filter fun input => ∃ position, AtPosition parameter input position
+
+attribute [local irreducible] structuralInputs
+
+theorem mem_structuralInputs (parameter : PublicParameter) (inputs : Finset HashInput) (input : HashInput) :
+    input ∈ structuralInputs parameter inputs ↔ input ∈ inputs ∧ ∃ position, AtPosition parameter input position := by
+  rw [structuralInputs, Finset.mem_filter]
+
+theorem structuralInputs_subset (parameter : PublicParameter) (inputs : Finset HashInput) : structuralInputs parameter inputs ⊆ inputs :=
+  fun input hi => ((mem_structuralInputs parameter inputs input).mp hi).1
+
+noncomputable def structuralInputCell (parameter : PublicParameter) (inputs : Finset HashInput) : structuralInputs parameter inputs → inputs :=
+  Set.inclusion (structuralInputs_subset parameter inputs)
+
+theorem structuralInputCell_injective (parameter : PublicParameter) (inputs : Finset HashInput) :
+    Function.Injective (structuralInputCell parameter inputs) := Set.inclusion_injective (structuralInputs_subset parameter inputs)
+
+abbrev NonstructuralRows (parameter : PublicParameter) (inputs : Finset HashInput) :=
+  UniformTableSplit.Outside (structuralInputCell parameter inputs) → HashOutput
+
+noncomputable def joinStructuralTable (parameter : PublicParameter) (inputs : Finset HashInput)
+    (rows : structuralInputs parameter inputs → HashOutput) (outside : NonstructuralRows parameter inputs) : inputs → HashOutput :=
+  UniformTableSplit.join (structuralInputCell parameter inputs) (structuralInputCell_injective parameter inputs) rows outside
+
+theorem joinStructuralTable_agrees_outside (parameter : PublicParameter) (inputs : Finset HashInput)
+    (left right : structuralInputs parameter inputs → HashOutput) (outside : NonstructuralRows parameter inputs)
+    (input : HashInput) (hn : input ∉ structuralInputs parameter inputs) :
+    finiteHashAnswer ∅ inputs (joinStructuralTable parameter inputs left outside) input =
+      finiteHashAnswer ∅ inputs (joinStructuralTable parameter inputs right outside) input := by
+  by_cases hin : input ∈ inputs
+  · rw [finiteHashAnswer_none ∅ inputs _ _ hin (by simp), finiteHashAnswer_none ∅ inputs _ _ hin (by simp)]
+    let cell : UniformTableSplit.Outside (structuralInputCell parameter inputs) :=
+      ⟨⟨input, hin⟩, UniformTableSplit.inclusion_not_range (structuralInputs_subset parameter inputs) ⟨input, hin⟩ hn⟩
+    exact (UniformTableSplit.join_outside _ _ left outside cell).trans
+      (UniformTableSplit.join_outside _ _ right outside cell).symm
+  · simp only [finiteHashAnswer, QueryCache.empty_apply, Option.getD_none, dif_neg hin]
+
+noncomputable def structuralAnswer (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels)
+    (outside : NonstructuralRows key.parameter inputs) (rows : structuralInputs key.parameter inputs → HashOutput) : QueryImpl HashSpec Id :=
+  programmedHash key.parameter key.otsSecret key.ftsSecret labels
+    (finiteHashAnswer ∅ inputs (joinStructuralTable key.parameter inputs rows outside))
+
+theorem structuralAnswer_graph (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels)
+    (outside : NonstructuralRows key.parameter inputs) (rows : structuralInputs key.parameter inputs → HashOutput) :
+    canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret (structuralAnswer key inputs labels outside rows) = labels :=
+  canonicalGraphLabels_programmedHash _ _ _ _ _
+
+theorem structuralAnswer_nonstructural (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels)
+    (outside : NonstructuralRows key.parameter inputs) (left right : structuralInputs key.parameter inputs → HashOutput)
+    (input : HashInput) (hn : ¬∃ position, AtPosition key.parameter input position) :
+    structuralAnswer key inputs labels outside left input = structuralAnswer key inputs labels outside right input := by
+  have hnot : input ∉ structuralInputs key.parameter inputs := fun hi => hn ((mem_structuralInputs _ _ _).mp hi).2
+  have hcanonical : ∀ position, input ≠ canonicalGraphInput key.parameter key.otsSecret key.ftsSecret position labels :=
+    fun position he => hn ⟨position, ⟨_, he⟩⟩
+  rw [structuralAnswer, structuralAnswer, programmedHash_other _ _ _ _ _ input hcanonical,
+    programmedHash_other _ _ _ _ _ input hcanonical]
+  exact joinStructuralTable_agrees_outside key.parameter inputs left right outside input hnot
+
+theorem structuralAnswer_selections (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels)
+    (outside : NonstructuralRows key.parameter inputs) (left right : structuralInputs key.parameter inputs → HashOutput) :
+    referenceTableSelection key (structuralAnswer key inputs labels outside left) =
+      referenceTableSelection key (structuralAnswer key inputs labels outside right) := by
+  funext position
+  rw [referenceTableSelection, referenceTableSelection, structuralAnswer_graph, structuralAnswer_graph]
+  apply congrArg (FirstSuccessTable.select decodeEncodingOutput)
+  funext counter
+  apply structuralAnswer_nonstructural
+  rintro ⟨other, ho⟩
+  exact (show AtEncodingPosition key.parameter (canonicalEncodingRowInput key.parameter labels (position, counter)) position from
+    ⟨_, rfl⟩).not_atPosition other ho
+
+theorem structuralAnswer_message (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels)
+    (outside : NonstructuralRows key.parameter inputs) (left right : structuralInputs key.parameter inputs → HashOutput)
+    (payload : HashInput) :
+    structuralAnswer key inputs labels outside left (tweakableHashInput key.parameter .message payload) =
+      structuralAnswer key inputs labels outside right (tweakableHashInput key.parameter .message payload) := by
+  apply structuralAnswer_nonstructural
+  rintro ⟨position, hp⟩
+  have hd := (decodePosition_some_iff key.parameter _ position).mpr hp
+  rw [decodePosition_message] at hd
+  contradiction
+
+noncomputable def structuralProgram (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels)
+    (outside : NonstructuralRows key.parameter inputs) (words : OtsReferenceWords) (adversary : Adversary) :
+    OracleComp OracleWorld (Bool × SigningBoundaryTrace) :=
+  CausalFrontierProgram.game key.parameter (structuralAnswer key inputs labels outside (fun _ => 0)) key.ftsSecret words
+    (canonicalGraphFrontier key.otsSecret labels words) adversary
+
+theorem structuralProgram_eq (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels)
+    (outside : NonstructuralRows key.parameter inputs) (rows : structuralInputs key.parameter inputs → HashOutput)
+    (words : OtsReferenceWords) (adversary : Adversary) :
+    CausalFrontierProgram.game key.parameter (structuralAnswer key inputs labels outside rows) key.ftsSecret words
+        (canonicalGraphFrontier key.otsSecret labels words) adversary = structuralProgram key inputs labels outside words adversary :=
+  CausalFrontierProgram.game_eq_of_graph key _ _ labels words (structuralAnswer_graph _ _ _ _ _) (structuralAnswer_graph _ _ _ _ _)
+    (structuralAnswer_selections _ _ _ _ _ _) (fun _ _ _ => structuralAnswer_message _ _ _ _ _ _ _) adversary
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/StructuralTraceCache.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/StructuralTraceCache.lean
new file mode 100644
index 000000000..2b1ee6f30
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/StructuralTraceCache.lean
@@ -0,0 +1,148 @@
+import SphincsSecurity.Proof.Hypertree.StructuralOracleObservation
+namespace SphincsSecurity.Concrete.StructuralObservation
+
+open _root_.OracleComp OracleSpec UniformTableCompletion RetainedObservation
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] structuralInputs canonicalGraphInputs Finset.univ
+
+def TraceConsistent (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels)
+    (trace : OtsContactTrace.Trace) (allowed : structuralInputs key.parameter inputs → Finset HashOutput) : Prop :=
+  (∀ row, Active key inputs labels row.val → ∀ output, (row.val, output) ∈ trace.toList → allowed row = {output}) ∧
+    ∀ row, Active key inputs labels row.val → (∀ output, (row.val, output) ∉ trace.toList) → allowed row = Finset.univ
+
+theorem traceConsistent_one (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels) :
+    TraceConsistent key inputs labels 1 (fun _ => Finset.univ) := by
+  constructor
+  · simp
+  · intros; rfl
+
+theorem TraceConsistent.inactive {key : SecretKey} {inputs : Finset HashInput} {labels : CanonicalGraphLabels}
+    {trace : OtsContactTrace.Trace} {allowed : structuralInputs key.parameter inputs → Finset HashOutput}
+    (h : TraceConsistent key inputs labels trace allowed) (input : HashInput) (hi : ¬Active key inputs labels input) (output : HashOutput) :
+    TraceConsistent key inputs labels (trace * FreeMonoid.of (input, output)) allowed := by
+  constructor
+  · intro row ha answer hentry
+    simp only [FreeMonoid.toList_mul, FreeMonoid.toList_of, List.mem_append, List.mem_singleton, Prod.mk.injEq] at hentry
+    rcases hentry with hentry | ⟨heq, _⟩
+    · exact h.1 row ha answer hentry
+    · exact False.elim (hi (heq ▸ ha))
+  · intro row ha hfresh
+    apply h.2 row ha
+    intro answer hentry
+    exact hfresh answer (List.mem_append_left _ hentry)
+
+theorem TraceConsistent.disclose {key : SecretKey} {inputs : Finset HashInput} {labels : CanonicalGraphLabels}
+    {trace : OtsContactTrace.Trace} {allowed : structuralInputs key.parameter inputs → Finset HashOutput}
+    (h : TraceConsistent key inputs labels trace allowed) (row : structuralInputs key.parameter inputs)
+    (ha : Active key inputs labels row.val) (output : HashOutput) (houtput : output ∈ allowed row) :
+    TraceConsistent key inputs labels (trace * FreeMonoid.of (row.val, output)) (discloseTableValue allowed row output) := by
+  constructor
+  · intro other hactive answer hentry
+    simp only [FreeMonoid.toList_mul, FreeMonoid.toList_of, List.mem_append, List.mem_singleton, Prod.mk.injEq] at hentry
+    rcases hentry with hentry | ⟨heq, rfl⟩
+    · by_cases heq : other = row
+      · subst other
+        have heq : output = answer := Finset.mem_singleton.mp ((h.1 row ha answer hentry) ▸ houtput)
+        simp only [discloseTableValue, Function.update_self, heq]
+      · rw [discloseTableValue, Function.update_of_ne heq]
+        exact h.1 other hactive answer hentry
+    · have heq : other = row := Subtype.ext heq
+      subst other
+      exact Function.update_self row {answer} allowed
+  · intro other hactive hfresh
+    have heq : other ≠ row := by
+      intro heq
+      subst other
+      exact hfresh output (List.mem_append_right _ (by simp))
+    rw [discloseTableValue, Function.update_of_ne heq]
+    apply h.2 other hactive
+    intro answer hentry
+    exact hfresh answer (List.mem_append_left _ hentry)
+
+noncomputable def lazyWorldImpl (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels)
+    (outside : NonstructuralRows key.parameter inputs) :
+    QueryImpl OracleWorld (StateT (structuralInputs key.parameter inputs → Finset HashOutput) SPMF) :=
+  (UniformTableObservation.lazyImpl (auxiliary key inputs labels outside)).compose (translate key inputs labels)
+
+theorem lazyRun_eq_simulate {Result : Type} (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels)
+    (outside : NonstructuralRows key.parameter inputs) (computation : OracleComp OracleWorld Result)
+    (allowed : structuralInputs key.parameter inputs → Finset HashOutput) :
+    lazyRun key inputs labels outside computation allowed = (simulateQ (lazyWorldImpl key inputs labels outside) computation).run allowed := by
+  rw [lazyRun, UniformTableObservation.lazyRun, lazyWorldImpl, QueryImpl.simulateQ_compose]
+
+theorem lazyRun_map {Result Next : Type} (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels)
+    (outside : NonstructuralRows key.parameter inputs) (computation : OracleComp OracleWorld Result) (f : Result → Next)
+    (allowed : structuralInputs key.parameter inputs → Finset HashOutput) :
+    lazyRun key inputs labels outside (f <$> computation) allowed =
+      (fun result => (f result.1, result.2)) <$> lazyRun key inputs labels outside computation allowed := by
+  simp only [lazyRun_eq_simulate, simulateQ_map, StateT.run_map]
+
+theorem lazyWorldImpl_traceConsistent (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels)
+    (outside : NonstructuralRows key.parameter inputs) (allowed : structuralInputs key.parameter inputs → Finset HashOutput)
+    (trace : OtsContactTrace.Trace) (h : TraceConsistent key inputs labels trace allowed) (input : OracleWorld.Domain)
+    (result : OracleWorld.Range input × (structuralInputs key.parameter inputs → Finset HashOutput))
+    (hr : (lazyWorldImpl key inputs labels outside input).run allowed result ≠ 0) :
+    TraceConsistent key inputs labels (trace * hashObservationTrace input result.1) result.2 := by
+  cases input with
+  | inl input =>
+      simp only [lazyWorldImpl, QueryImpl.compose, translate, simulateQ_spec_query,
+        UniformTableObservation.lazyImpl, StateT.run_mk, ← bind_pure_comp] at hr
+      obtain ⟨answer, _, heq⟩ := (bind_nonzero _ _ _).mp hr
+      simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at heq
+      subst result
+      simpa only [hashObservationTrace, mul_one] using h
+  | inr input =>
+      by_cases ha : Active key inputs labels input
+      · simp only [lazyWorldImpl, QueryImpl.compose, translate, dif_pos ha, simulateQ_spec_query,
+          UniformTableObservation.lazyImpl, StateT.run_mk, ← bind_pure_comp] at hr
+        obtain ⟨answer, ho, heq⟩ := (bind_nonzero _ _ _).mp hr
+        simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at heq
+        subst result
+        have hin : answer ∈ allowed ⟨input, ha.1⟩ := by
+          by_contra hn
+          simp only [cell_apply, if_neg hn, ne_eq, not_true_eq_false] at ho
+        exact h.disclose ⟨input, ha.1⟩ ha answer hin
+      · simp only [lazyWorldImpl, QueryImpl.compose, translate, dif_neg ha, simulateQ_spec_query,
+          UniformTableObservation.lazyImpl, StateT.run_mk, ← bind_pure_comp] at hr
+        obtain ⟨answer, _, heq⟩ := (bind_nonzero _ _ _).mp hr
+        simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at heq
+        subst result
+        exact h.inactive input ha answer
+
+theorem TraceConsistent.cached_reply {key : SecretKey} {inputs : Finset HashInput} {labels : CanonicalGraphLabels}
+    {trace : OtsContactTrace.Trace} {allowed : structuralInputs key.parameter inputs → Finset HashOutput}
+    (h : TraceConsistent key inputs labels trace allowed) (row : structuralInputs key.parameter inputs)
+    (ha : Active key inputs labels row.val) (previous output : HashOutput) (hp : (row.val, previous) ∈ trace.toList)
+    (ho : cell (allowed row) output ≠ 0) : output = previous := by
+  rw [h.1 row ha previous hp, cell_apply] at ho
+  by_contra hn
+  simp only [Finset.mem_singleton, hn, if_false, ne_eq, not_true_eq_false] at ho
+
+theorem TraceConsistent.new_reply_probability_le {key : SecretKey} {inputs : Finset HashInput} {labels : CanonicalGraphLabels}
+    {trace : OtsContactTrace.Trace} {allowed : structuralInputs key.parameter inputs → Finset HashOutput}
+    (h : TraceConsistent key inputs labels trace allowed) (row : structuralInputs key.parameter inputs)
+    (ha : Active key inputs labels row.val) (event : HashOutput → Prop) :
+    Pr[fun output => event output ∧ (row.val, output) ∉ trace.toList | cell (allowed row)] ≤ Pr[event | cell Finset.univ] := by
+  by_cases hfresh : ∀ output, (row.val, output) ∉ trace.toList
+  · rw [h.2 row ha hfresh]
+    exact _root_.probEvent_mono (fun _ _ he => he.1)
+  · obtain ⟨previous, hp⟩ := not_forall.mp hfresh
+    have hp : (row.val, previous) ∈ trace.toList := not_not.mp hp
+    have hz : Pr[fun output => event output ∧ (row.val, output) ∉ trace.toList | cell (allowed row)] = 0 := by
+      apply probEvent_eq_zero
+      intro output ho he
+      have heq := h.cached_reply row ha previous output hp ((SPMF.mem_support_iff _ _).mp ho)
+      exact he.2 (heq.symm ▸ hp)
+    rw [hz]
+    exact bot_le
+
+theorem lazyRun_neverFail {Result : Type} (key : SecretKey) (inputs : Finset HashInput) (labels : CanonicalGraphLabels)
+    (outside : NonstructuralRows key.parameter inputs) (computation : OracleComp OracleWorld Result)
+    (allowed : structuralInputs key.parameter inputs → Finset HashOutput) (ha : ∀ row, (allowed row).Nonempty) :
+    NeverFail (lazyRun key inputs labels outside computation allowed) := by
+  apply UniformTableObservation.lazyRun_neverFail _ _ _ _ ha
+  intro input
+  exact ⟨probFailure_eq_zero (mx := fixedHashWorld (structuralAnswer key inputs labels outside (fun _ => 0)) input)⟩
+
+end SphincsSecurity.Concrete.StructuralObservation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Hypertree/TreeFoldBound.lean b/formal/sphincs/SphincsSecurity/Proof/Hypertree/TreeFoldBound.lean
new file mode 100644
index 000000000..215d1cba1
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Hypertree/TreeFoldBound.lean
@@ -0,0 +1,13 @@
+import SphincsSecurity.Proof.Base.Prelude
+namespace SphincsSecurity.Concrete
+
+theorem fold_node_bound (height level index : Nat) (hlevel : level < height) (hindex : index < 2 ^ height) :
+    2 ^ (level + 1) * (index / 2 ^ (level + 1) + 1) ≤ 2 ^ height := by
+  have hpow : (2 : Nat) ^ height = 2 ^ (level + 1) * 2 ^ (height - (level + 1)) := by
+    rw [← pow_add, Nat.add_sub_of_le (Nat.succ_le_of_lt hlevel)]
+  have hdiv : index / 2 ^ (level + 1) < 2 ^ (height - (level + 1)) := by
+    apply (Nat.div_lt_iff_lt_mul (by positivity)).mpr
+    simpa only [hpow, Nat.mul_comm] using hindex
+  exact (Nat.mul_le_mul_left _ (Nat.succ_le_of_lt hdiv)).trans_eq hpow.symm
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/CanonicalEncodingSampling.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/CanonicalEncodingSampling.lean
new file mode 100644
index 000000000..b592953c0
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/CanonicalEncodingSampling.lean
@@ -0,0 +1,110 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.CanonicalGraphHonest
+import SphincsSecurity.Proof.Ots.EncodingInputs
+import SphincsSecurity.Proof.Reference.FiniteHashWorld
+import SphincsSecurity.Proof.Ots.ReferenceEncodingTable
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec OracleComp.DeferredSampling
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def canonicalGraphMessage (labels : CanonicalGraphLabels) (position : EncodingPosition) : Digest :=
+  truncateHash (labels (layerMessagePosition
+    (referenceIndex position.lay position.tree position.leafIdx) position.lay))
+
+theorem layerMessagePosition_treeBound (index : Index) (lay : Layer) :
+    (layerMessagePosition index lay).TreeBound := by
+  unfold layerMessagePosition
+  split_ifs <;> norm_num [Position.TreeBound, layerHeight, middleLayer, bottomLayer, topLayer, numLayers,
+    maxLayerHeight]
+
+theorem canonicalGraphMessage_eq (key : SecretKey) (f : QueryImpl HashSpec Id) (position : EncodingPosition) :
+    canonicalGraphMessage (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f) position =
+      evalWithAnswerFn f (layerMessage key (referenceIndex position.lay position.tree position.leafIdx) position.lay) := by
+  rw [canonicalGraphMessage, canonicalGraphLabels_eq_honest _ _ _ _ _ (layerMessagePosition_treeBound _ _),
+    eval_layerMessage_eq_honestValue]
+  rfl
+
+theorem canonicalEncodingSearch_eq_graph_table (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (position : EncodingPosition) :
+    canonicalEncodingSearch key f position.lay position.tree position.leafIdx =
+      encodingTableResult (referenceEncodingTable key.parameter f position
+        (canonicalGraphMessage (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f) position)
+        encodingAttemptLimit 0) 0 := by
+  rw [canonicalEncodingSearch, canonicalGraphMessage_eq, referenceEncodingSearch_eq_table]
+
+abbrev EncodingRow := EncodingPosition × Fin encodingAttemptLimit
+abbrev CanonicalEncodingRows := EncodingRow → HashOutput
+
+noncomputable def canonicalEncodingRowInput (parameter : PublicParameter) (labels : CanonicalGraphLabels)
+    (row : EncodingRow) : HashInput :=
+  encodingRetryInput parameter row.1 (canonicalGraphMessage labels row.1) row.2.val
+
+theorem canonicalEncodingRowInput_injective (parameter : PublicParameter) (labels : CanonicalGraphLabels) :
+    Function.Injective (canonicalEncodingRowInput parameter labels) := by
+  rintro ⟨left, first⟩ ⟨right, second⟩ heq
+  have hposition : left = right := atEncodingPosition_unique
+    (show AtEncodingPosition parameter (canonicalEncodingRowInput parameter labels (left, first)) left from ⟨_, rfl⟩)
+    (show AtEncodingPosition parameter (canonicalEncodingRowInput parameter labels (left, first)) right from
+      ⟨_, heq⟩)
+  subst right
+  have hcounter := encodingRetryInput_injective_of_lt first.isLt second.isLt heq
+  exact Prod.ext rfl (Fin.ext hcounter)
+
+attribute [local irreducible] canonicalEncodingInputs
+
+theorem canonicalEncodingRowInput_mem (parameter : PublicParameter) (labels : CanonicalGraphLabels)
+    (row : EncodingRow) : canonicalEncodingRowInput parameter labels row ∈ canonicalEncodingInputs parameter := by
+  rw [canonicalEncodingInputs, Finset.mem_biUnion]
+  simp only [Finset.mem_univ, true_and]
+  refine ⟨row.1, ?_⟩
+  simp only [Finset.mem_image, Finset.mem_univ, true_and]
+  exact ⟨(canonicalGraphMessage labels row.1, row.2), rfl⟩
+
+noncomputable def canonicalEncodingCell (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hinputs : canonicalEncodingInputs parameter ⊆ inputs) (labels : CanonicalGraphLabels) (row : EncodingRow) : inputs :=
+  ⟨canonicalEncodingRowInput parameter labels row, hinputs (canonicalEncodingRowInput_mem parameter labels row)⟩
+
+theorem canonicalEncodingCell_injective (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hinputs : canonicalEncodingInputs parameter ⊆ inputs) (labels : CanonicalGraphLabels) :
+    Function.Injective (canonicalEncodingCell parameter inputs hinputs labels) := by
+  intro left right heq
+  exact canonicalEncodingRowInput_injective parameter labels (congrArg Subtype.val heq)
+
+noncomputable local instance instSampleableTypeForallSubtypeHashInputMemFinsetHashOutput_2 (inputs : Finset HashInput) : SampleableType (inputs → HashOutput) :=
+  SampleableType.ofFintype (inputs → HashOutput)
+
+noncomputable local instance instSampleableTypeCanonicalGraphLabels_1 : SampleableType CanonicalGraphLabels := SampleableType.ofFintype CanonicalGraphLabels
+
+noncomputable local instance instSampleableTypeCanonicalEncodingRows : SampleableType CanonicalEncodingRows := SampleableType.ofFintype CanonicalEncodingRows
+
+noncomputable local instance instSampleableTypeForallFinEncodingAttemptLimitHashOutput : SampleableType (Fin encodingAttemptLimit → HashOutput) :=
+  SampleableType.ofFintype (Fin encodingAttemptLimit → HashOutput)
+
+noncomputable def readCanonicalEncodingRows (parameter : PublicParameter) (labels : CanonicalGraphLabels)
+    (f : QueryImpl HashSpec Id) : CanonicalEncodingRows := fun row => f (canonicalEncodingRowInput parameter labels row)
+
+theorem readCanonicalEncodingRows_finite (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hinputs : canonicalEncodingInputs parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (table : inputs → HashOutput) :
+    readCanonicalEncodingRows parameter labels (finiteHashAnswer ∅ inputs table) =
+      table ∘ canonicalEncodingCell parameter inputs hinputs labels := by
+  funext row
+  exact finiteHashAnswer_none ∅ inputs table _ (hinputs (canonicalEncodingRowInput_mem parameter labels row)) (by simp)
+
+def canonicalEncodingResults (rows : CanonicalEncodingRows) : EncodingPosition → Option (Counter × Encoding) × Nat :=
+  fun position => encodingTableResult (fun counter => rows (position, counter)) 0
+
+theorem canonicalEncodingResults_eq (key : SecretKey) (f : QueryImpl HashSpec Id) :
+    canonicalEncodingResults (readCanonicalEncodingRows key.parameter
+      (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f) f) =
+        fun position => canonicalEncodingSearch key f position.lay position.tree position.leafIdx := by
+  funext position
+  rw [canonicalEncodingSearch_eq_graph_table]
+  apply congrArg (fun table => encodingTableResult table 0)
+  funext counter
+  simp only [readCanonicalEncodingRows, canonicalEncodingRowInput, referenceEncodingTable]
+  rw [Nat.zero_add]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/Chain.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/Chain.lean
new file mode 100644
index 000000000..f65abd237
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/Chain.lean
@@ -0,0 +1,30 @@
+import SphincsSecurity.Proof.Base.Prelude
+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/Ots/EncodingAdaptiveMarker.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingAdaptiveMarker.lean
new file mode 100644
index 000000000..076611dbc
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingAdaptiveMarker.lean
@@ -0,0 +1,86 @@
+import SphincsSecurity.Proof.Ots.EncodingTraceCache
+import SphincsSecurity.Proof.Ots.EncodingMarkerKernel
+namespace SphincsSecurity.Concrete.OtsEncodingMarker
+
+open _root_.OracleComp OracleSpec UniformTableCompletion EncodingObservation
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] Finset.univ canonicalEncodingInputs markers
+
+def NewMarker (parameter : PublicParameter) (words : OtsReferenceWords) (history : OtsContactTrace.Trace)
+    (address : OtsPrefix.ChainAddress) (entry : HashInput × HashOutput) : Prop :=
+  EntryMarker parameter words address entry ∧ ¬Seen parameter words address history
+
+theorem NewMarker.not_mem {parameter : PublicParameter} {words : OtsReferenceWords} {history : OtsContactTrace.Trace}
+    {address : OtsPrefix.ChainAddress} {entry : HashInput × HashOutput}
+    (h : NewMarker parameter words history address entry) : entry ∉ history.toList :=
+  fun hin => h.2 ⟨entry, hin, h.1⟩
+
+theorem newMarker_cell_le (parameter : PublicParameter) (messages : EncodingPosition → Digest)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords) (history : OtsContactTrace.Trace)
+    (allowed : canonicalEncodingInputs parameter → Finset HashOutput)
+    (hc : TraceConsistent parameter (referenceEncodingAllowed parameter messages selections) history allowed)
+    (address : OtsPrefix.ChainAddress) (row : canonicalEncodingInputs parameter) :
+    Pr[fun output => NewMarker parameter (referenceFamilyWords selections dummy) history address (row.val, output) |
+      cell (allowed row)] ≤ 41 / (Fintype.card Digest : ENNReal) := by
+  refine (_root_.probEvent_mono (fun _ _ h => ⟨h.1, h.not_mem⟩)).trans
+    ((hc.new_reply_probability_le row (fun output => EntryMarker parameter (referenceFamilyWords selections dummy) address
+      (row.val, output))).trans ?_)
+  simpa only [cell, dif_pos (referenceEncodingAllowed_nonempty parameter messages selections row), SPMF.probEvent_liftM] using
+    entryMarker_allowed_le parameter messages selections dummy address row
+
+theorem newMarker_subset_cell_le (parameter : PublicParameter) (messages : EncodingPosition → Digest)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords) (history : OtsContactTrace.Trace)
+    (allowed : canonicalEncodingInputs parameter → Finset HashOutput)
+    (hc : TraceConsistent parameter (referenceEncodingAllowed parameter messages selections) history allowed)
+    (addresses : Finset OtsPrefix.ChainAddress) (row : canonicalEncodingInputs parameter) :
+    Pr[fun output => ∃ address ∈ addresses, NewMarker parameter (referenceFamilyWords selections dummy) history address (row.val, output) |
+      cell (allowed row)] ≤ (41 * (addresses.card : ENNReal)) / Fintype.card Digest := by
+  have h := (probEvent_exists_finset_le_sum addresses (cell (allowed row))
+    (fun address output => NewMarker parameter (referenceFamilyWords selections dummy) history address (row.val, output))).trans
+    (Finset.sum_le_sum fun address _ => newMarker_cell_le parameter messages selections dummy history allowed hc address row)
+  simpa only [Finset.sum_const, nsmul_eq_mul, div_eq_mul_inv, mul_comm, mul_left_comm, mul_assoc] using h
+
+theorem newMarker_any_cell_le (parameter : PublicParameter) (messages : EncodingPosition → Digest)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords) (history : OtsContactTrace.Trace)
+    (allowed : canonicalEncodingInputs parameter → Finset HashOutput)
+    (hc : TraceConsistent parameter (referenceEncodingAllowed parameter messages selections) history allowed)
+    (row : canonicalEncodingInputs parameter) :
+    Pr[fun output => ∃ address, NewMarker parameter (referenceFamilyWords selections dummy) history address (row.val, output) |
+      cell (allowed row)] ≤ 1722 / (Fintype.card Digest : ENNReal) := by
+  refine (_root_.probEvent_mono (fun _ _ h => ?_)).trans
+    ((hc.new_reply_probability_le row (fun output => ∃ address, EntryMarker parameter (referenceFamilyWords selections dummy) address
+      (row.val, output))).trans ?_)
+  · obtain ⟨address, hm⟩ := h
+    exact ⟨⟨address, hm.1⟩, hm.not_mem⟩
+  · simpa only [cell, dif_pos (referenceEncodingAllowed_nonempty parameter messages selections row), SPMF.probEvent_liftM] using
+      entryMarker_any_allowed_le parameter messages selections dummy row
+
+section Cardinality
+
+local instance (priority := 11000) : DecidableEq OtsPrefix.ChainAddress := inferInstance
+attribute [local instance 10000] Classical.propDecidable
+
+theorem markers_step_card (parameter : PublicParameter) (words : OtsReferenceWords)
+    (history : OtsContactTrace.Trace) (entry : HashInput × HashOutput) :
+    (markers parameter words (history * FreeMonoid.of entry)).card = (markers parameter words history).card +
+      if ∃ address, NewMarker parameter words history address entry then 1 else 0 := by
+  rw [markers_mul]
+  by_cases hm : ∃ address, NewMarker parameter words history address entry
+  · obtain ⟨address, he, hn⟩ := hm
+    have hi : address ∈ markers parameter words (FreeMonoid.of entry) := (mem_markers _ _ _ _).mpr ((seen_of _ _ _ _).mpr he)
+    have hs : markers parameter words (FreeMonoid.of entry) = {address} :=
+      Finset.eq_singleton_iff_unique_mem.mpr ⟨hi, fun other ho =>
+        entryMarker_unique parameter words entry other address ((seen_of _ _ _ _).mp ((mem_markers _ _ _ _).mp ho)) he⟩
+    have ha : address ∉ markers parameter words history := fun hin => hn ((mem_markers _ _ _ _).mp hin)
+    rw [if_pos ⟨address, he, hn⟩, hs, Finset.union_singleton, Finset.card_insert_of_notMem ha]
+  · have hs : markers parameter words (FreeMonoid.of entry) ⊆ markers parameter words history := by
+      intro address hi
+      by_contra hn
+      exact hm ⟨address, (seen_of _ _ _ _).mp ((mem_markers _ _ _ _).mp hi),
+        fun hs => hn ((mem_markers _ _ _ _).mpr hs)⟩
+    rw [if_neg hm, Finset.union_eq_left.mpr hs, Nat.add_zero]
+
+end Cardinality
+
+end SphincsSecurity.Concrete.OtsEncodingMarker
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingBackwardWitness.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingBackwardWitness.lean
new file mode 100644
index 000000000..0aade513a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingBackwardWitness.lean
@@ -0,0 +1,111 @@
+import SphincsSecurity.Proof.Ots.EncodingNeighbors
+namespace SphincsSecurity.TargetSum
+
+open scoped BigOperators
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] Finset.univ
+
+def backwardWeight (reference candidate : Encoding) : Nat :=
+  ∑ index : ChainIndex, ((reference index).val - (candidate index).val)
+
+theorem backwardWeight_balance {reference candidate : Encoding} (hsum : sum reference = sum candidate) :
+    backwardWeight reference candidate = backwardWeight candidate reference := by
+  have hpoint : ∀ index : ChainIndex,
+      ((reference index).val - (candidate index).val) + (candidate index).val =
+        ((candidate index).val - (reference index).val) + (reference index).val := by intro index; omega
+  have h := congrArg (fun f : ChainIndex → Nat => ∑ index, f index) (funext hpoint)
+  simp only [Finset.sum_add_distrib] at h
+  change backwardWeight reference candidate + sum candidate = backwardWeight candidate reference + sum reference at h
+  omega
+
+private theorem two_terms_le_sum (f : ChainIndex → Nat) {left right : ChainIndex} (hne : left ≠ right) :
+    f left + f right ≤ ∑ index, f index := by
+  have h := Finset.sum_le_sum_of_subset_of_nonneg (f := f) (Finset.subset_univ ({left, right} : Finset ChainIndex))
+    (fun _ _ _ => Nat.zero_le _)
+  simpa only [Finset.sum_pair hne] using h
+
+private theorem single_of_sum_one (f : ChainIndex → Nat) (hsum : (∑ index, f index) = 1) :
+    ∃ index, f index = 1 ∧ ∀ other, other ≠ index → f other = 0 := by
+  have hnonzero : ∃ index, f index ≠ 0 := by
+    by_contra hnone
+    push Not at hnone
+    have hz : (∑ index, f index) = 0 := Finset.sum_eq_zero fun index _ => hnone index
+    omega
+  obtain ⟨index, hi⟩ := hnonzero
+  have hle : f index ≤ ∑ other, f other := Finset.single_le_sum (fun _ _ => Nat.zero_le _) (Finset.mem_univ index)
+  have hone : f index = 1 := by omega
+  refine ⟨index, hone, ?_⟩
+  intro other hne
+  have hpair := two_terms_le_sum f hne
+  omega
+
+theorem unitNeighbor_of_backwardWeight_one {reference candidate : Encoding}
+    (hsum : sum reference = sum candidate) (hweight : backwardWeight reference candidate = 1) :
+    ∃ lowered, UnitNeighborAt reference candidate lowered := by
+  obtain ⟨lowered, hlower, hothers⟩ := single_of_sum_one (fun index => (reference index).val - (candidate index).val) hweight
+  have hreverse : backwardWeight candidate reference = 1 := (backwardWeight_balance hsum).symm.trans hweight
+  obtain ⟨raised, hraise, hotherRaised⟩ := single_of_sum_one (fun index => (candidate index).val - (reference index).val) hreverse
+  refine ⟨lowered, raised, ?_, ?_, ?_, ?_⟩
+  · intro he
+    subst raised
+    omega
+  · omega
+  · omega
+  · intro index hl hr
+    have hdown := hothers index hl
+    have hup := hotherRaised index hr
+    apply Fin.ext
+    omega
+
+theorem eq_of_backwardWeight_zero {reference candidate : Encoding}
+    (hsum : sum reference = sum candidate) (hweight : backwardWeight reference candidate = 0) : reference = candidate := by
+  apply eq_of_le_of_sum_eq _ hsum
+  intro index
+  have hle : (reference index).val - (candidate index).val ≤ backwardWeight reference candidate := by
+    unfold backwardWeight
+    exact Finset.single_le_sum (f := fun index : ChainIndex => (reference index).val - (candidate index).val)
+      (fun _ _ => Nat.zero_le _) (Finset.mem_univ index)
+  omega
+
+theorem backwardWeight_two_witness {reference candidate : Encoding} (hweight : 2 ≤ backwardWeight reference candidate) :
+    (∃ index, (candidate index).val + 2 ≤ (reference index).val) ∨
+      ∃ left right, left ≠ right ∧ (candidate left).val < (reference left).val ∧ (candidate right).val < (reference right).val := by
+  by_cases hlarge : ∃ index, (candidate index).val + 2 ≤ (reference index).val
+  · exact Or.inl hlarge
+  have hnonzero : ∃ index, (candidate index).val < (reference index).val := by
+    by_contra hnone
+    push Not at hnone
+    have hz : backwardWeight reference candidate = 0 := by
+      apply Finset.sum_eq_zero
+      intro index _
+      exact Nat.sub_eq_zero_of_le (hnone index)
+    omega
+  obtain ⟨left, hl⟩ := hnonzero
+  by_cases hother : ∃ right, left ≠ right ∧ (candidate right).val < (reference right).val
+  · obtain ⟨right, hne, hr⟩ := hother
+    exact Or.inr ⟨left, right, hne, hl, hr⟩
+  · have hzero : ∀ index, index ≠ left → (reference index).val - (candidate index).val = 0 := by
+      intro index hne
+      have hn : ¬(candidate index).val < (reference index).val := fun hi => hother ⟨index, hne.symm, hi⟩
+      omega
+    have hsum : backwardWeight reference candidate = (reference left).val - (candidate left).val := by
+      apply Finset.sum_eq_single left
+      · intro index _ hne
+        exact hzero index hne
+      · simp only [Finset.mem_univ, not_true_eq_false, false_implies]
+    have hn := not_exists.mp hlarge left
+    omega
+
+theorem valid_encoding_classification {reference candidate : Encoding} (hreference : Valid reference) (hcandidate : Valid candidate) :
+    reference = candidate ∨ (∃ lowered, UnitNeighborAt reference candidate lowered) ∨
+      (∃ index, (candidate index).val + 2 ≤ (reference index).val) ∨
+      ∃ left right, left ≠ right ∧ (candidate left).val < (reference left).val ∧ (candidate right).val < (reference right).val := by
+  have hsum : sum reference = sum candidate := hreference.trans hcandidate.symm
+  by_cases hzero : backwardWeight reference candidate = 0
+  · exact Or.inl (eq_of_backwardWeight_zero hsum hzero)
+  by_cases hone : backwardWeight reference candidate = 1
+  · exact Or.inr (Or.inl (unitNeighbor_of_backwardWeight_one hsum hone))
+  exact Or.inr (Or.inr (backwardWeight_two_witness (by omega)))
+
+end SphincsSecurity.TargetSum
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingCached.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingCached.lean
new file mode 100644
index 000000000..626b63dbd
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingCached.lean
@@ -0,0 +1,33 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Scheme.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
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingCharge.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingCharge.lean
new file mode 100644
index 000000000..945638d0d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingCharge.lean
@@ -0,0 +1,50 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Ots.EncodingTarget
+/-!
+# 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.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
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingConditionalObservation.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingConditionalObservation.lean
new file mode 100644
index 000000000..915e1bb07
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingConditionalObservation.lean
@@ -0,0 +1,55 @@
+import SphincsSecurity.Proof.Ots.EncodingFreshRow
+import SphincsSecurity.Proof.Ots.ReferenceFamilyGame
+import SphincsSecurity.Proof.Base.UniformTableObservation
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec UniformTableCompletion
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] Finset.univ
+
+noncomputable def encodingSelectionAllowed (selection : ReferenceSelection) : Fin encodingAttemptLimit → Finset HashOutput :=
+  match selection with
+  | none => fun _ => FirstSuccessTable.invalid decodeEncodingOutput
+  | some (index, word) =>
+      if (FirstSuccessTable.fiber decodeEncodingOutput word).Nonempty then
+        FirstSuccessTable.allowed decodeEncodingOutput index word else fun _ => Finset.univ
+
+theorem encodingSelectionAllowed_nonempty (selection : ReferenceSelection) :
+    ∀ coordinate, (encodingSelectionAllowed selection coordinate).Nonempty := by
+  cases selection with
+  | none => exact fun _ => decodeEncodingOutput_invalid_nonempty
+  | some selected =>
+      obtain ⟨index, word⟩ := selected
+      simp only [encodingSelectionAllowed]
+      split_ifs with hfiber
+      · exact FirstSuccessTable.allowed_nonempty decodeEncodingOutput index word decodeEncodingOutput_invalid_nonempty hfiber
+      · exact fun _ => Finset.univ_nonempty
+
+theorem encodingSelectionAllowed_fresh (selection : ReferenceSelection) (dummy : Encoding) (coordinate : Fin encodingAttemptLimit) :
+    FreshEncodingSupport ((selection.map Prod.snd).getD dummy) (encodingSelectionAllowed selection coordinate) := by
+  cases selection with
+  | none =>
+      exact Or.inr fun output ho => Or.inl ((FirstSuccessTable.mem_invalid _ _).mp ho)
+  | some selected =>
+      obtain ⟨index, word⟩ := selected
+      simp only [Option.map_some, Option.getD_some, encodingSelectionAllowed]
+      split_ifs
+      · exact firstSuccess_allowed_fresh index word coordinate
+      · exact Or.inl rfl
+
+theorem encoding_afterSelect_complete (selection : ReferenceSelection) :
+    𝒟[FirstSuccessTable.afterSelect decodeEncodingOutput encodingAttemptLimit decodeEncodingOutput_invalid_nonempty selection] =
+      complete (encodingSelectionAllowed selection) := by
+  rw [complete_of_nonempty _ (encodingSelectionAllowed_nonempty selection)]
+  cases selection with
+  | none => rfl
+  | some selected =>
+      obtain ⟨index, word⟩ := selected
+      by_cases hfiber : (FirstSuccessTable.fiber decodeEncodingOutput word).Nonempty
+      · simp only [FirstSuccessTable.afterSelect, dif_pos hfiber, encodingSelectionAllowed, if_pos hfiber]
+        rfl
+      · simp only [FirstSuccessTable.afterSelect, dif_neg hfiber, encodingSelectionAllowed, if_neg hfiber]
+        rfl
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingContactMarkerAccumulation.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingContactMarkerAccumulation.lean
new file mode 100644
index 000000000..a220490d3
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingContactMarkerAccumulation.lean
@@ -0,0 +1,55 @@
+import SphincsSecurity.Proof.Ots.EncodingContactMarkerStep
+import SphincsSecurity.Proof.Ots.EncodingMarkerAccumulation
+namespace SphincsSecurity.Concrete.EncodingObservation
+
+open _root_.OracleComp OracleSpec OtsEncodingMarker
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] Finset.univ canonicalEncodingInputs OtsContactTrace.contacts
+
+theorem contactMarker_lazyRun_le {Result : Type} (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (outside : NonencodingRows parameter inputs hencoding)
+    (messages : EncodingPosition → Digest) (selections : ReferenceFamily) (dummy : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (computation : OracleComp OracleWorld Result) (history : OtsContactTrace.Trace)
+    (allowed : canonicalEncodingInputs parameter → Finset HashOutput)
+    (hc : TraceConsistent parameter (referenceEncodingAllowed parameter messages selections) history allowed)
+    (ha : ∀ row, (allowed row).Nonempty) :
+    (∑' result, Pr[= result | lazyRun parameter inputs hencoding outside (QueryPause.traced hashObservationTrace computation) allowed] *
+      (contactMarkerCount parameter (referenceFamilyWords selections dummy) frontier (history * result.1.2) : ENNReal)) ≤
+      (contactMarkerCount parameter (referenceFamilyWords selections dummy) frontier history : ENNReal) +
+        (41 / (Fintype.card Digest : ENNReal)) * ∑' result,
+          Pr[= result | lazyRun parameter inputs hencoding outside (QueryPause.traced hashObservationTrace computation) allowed] *
+            (contactMarkerCost parameter (referenceFamilyWords selections dummy) frontier history result.1.2 : ENNReal) := by
+  simp only [lazyRun_eq_simulate]
+  apply QueryPause.traced_spmf_history_potential_le hashObservationTrace (lazyWorldImpl parameter inputs hencoding outside)
+    (fun history allowed => TraceConsistent parameter (referenceEncodingAllowed parameter messages selections) history allowed ∧
+      ∀ row, (allowed row).Nonempty)
+    _ _ (fun history _ => contactMarkerCount parameter (referenceFamilyWords selections dummy) frontier history)
+    _ (contactMarkerCost parameter (referenceFamilyWords selections dummy) frontier) _
+    (contactMarkerCost_one parameter (referenceFamilyWords selections dummy) frontier)
+    (contactMarkerCost_step parameter (referenceFamilyWords selections dummy) frontier) _ computation history allowed ⟨hc, ha⟩
+  · intro history allowed hi input result hr
+    exact ⟨lazyWorldImpl_traceConsistent parameter inputs hencoding outside _ allowed history hi.1 input result hr,
+      UniformTableObservation.lazyRun_nonempty (auxiliary parameter inputs hencoding outside) (translate parameter input)
+        allowed hi.2 result hr⟩
+  · intro computation history allowed hi
+    rw [← lazyRun_eq_simulate]
+    exact probFailure_eq_zero' (lazyRun_neverFail parameter inputs hencoding outside _ allowed hi.2)
+  · intro history allowed hi input
+    exact contactMarker_query_potential_le parameter inputs hencoding outside messages selections dummy frontier history allowed hi.1 input
+
+theorem contactMarker_initial_lazyRun_le {Result : Type} (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (outside : NonencodingRows parameter inputs hencoding)
+    (messages : EncodingPosition → Digest) (selections : ReferenceFamily) (dummy : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (computation : OracleComp OracleWorld Result) :
+    (∑' result, Pr[= result | lazyRun parameter inputs hencoding outside (QueryPause.traced hashObservationTrace computation)
+      (referenceEncodingAllowed parameter messages selections)] *
+      (contactMarkerCount parameter (referenceFamilyWords selections dummy) frontier result.1.2 : ENNReal)) ≤
+        (41 / (Fintype.card Digest : ENNReal)) * ∑' result,
+          Pr[= result | lazyRun parameter inputs hencoding outside (QueryPause.traced hashObservationTrace computation)
+            (referenceEncodingAllowed parameter messages selections)] *
+              (contactMarkerCost parameter (referenceFamilyWords selections dummy) frontier 1 result.1.2 : ENNReal) := by
+  simpa only [one_mul, contactMarkerCount_one, Nat.cast_zero, zero_add] using
+    contactMarker_lazyRun_le parameter inputs hencoding outside messages selections dummy frontier computation 1 _
+      (traceConsistent_one parameter _) (referenceEncodingAllowed_nonempty parameter messages selections)
+
+end SphincsSecurity.Concrete.EncodingObservation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingContactMarkerSource.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingContactMarkerSource.lean
new file mode 100644
index 000000000..75866a5f3
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingContactMarkerSource.lean
@@ -0,0 +1,81 @@
+import SphincsSecurity.Proof.Ots.EncodingContactMarkerAccumulation
+import SphincsSecurity.Proof.Ots.EncodingMarkerBound
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec OtsEncodingMarker
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalGraphLabels canonicalGraphInputs canonicalEncodingInputs Finset.univ OtsContactTrace.contacts
+
+theorem referenceEncodingLazyRest_frontier_statistic (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (outside : NonencodingRows key.parameter inputs hencoding)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords) (adversary : Adversary)
+    (statistic : OtsFrontierValues → OtsContactTrace.Trace → ENNReal) :
+    (∑' result, Pr[= result | referenceEncodingLazyRest contactObserver key inputs hencoding outside selections dummy adversary] *
+      statistic result.1.frontier (result.1.before * result.1.after)) =
+      let frontier := canonicalGraphFrontier key.otsSecret (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret
+        (nonencodingAnswer key.parameter inputs hencoding outside)) (referenceFamilyWords selections dummy)
+      ∑' result, Pr[= result | EncodingObservation.lazyRun key.parameter inputs hencoding outside
+        (QueryPause.traced hashObservationTrace (referenceEncodingProgram key inputs hencoding outside selections dummy adversary))
+        (referenceEncodingAllowed key.parameter (outsideGraphMessage key inputs hencoding outside) selections)] *
+          statistic frontier result.1.2 := by
+  dsimp only
+  unfold referenceEncodingLazyRest
+  have h := contactObserver_frontier_trace key.parameter (referenceFamilyWords selections dummy)
+    (canonicalGraphFrontier key.otsSecret (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret
+      (nonencodingAnswer key.parameter inputs hencoding outside)) (referenceFamilyWords selections dummy))
+    (referenceEncodingProgram key inputs hencoding outside selections dummy adversary)
+  have he := congrArg (fun computation => EncodingObservation.lazyRun key.parameter inputs hencoding outside computation
+    (referenceEncodingAllowed key.parameter (outsideGraphMessage key inputs hencoding outside) selections)) h
+  simp only [EncodingObservation.lazyRun_map] at he
+  have hs := congrArg (fun law => ∑' result, Pr[= result | law] * statistic result.1.1 result.1.2.2) he
+  simpa only [tsum_probOutput_map_mul] using hs
+
+theorem referenceEncodingLazyRest_contactMarker_le (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (outside : NonencodingRows key.parameter inputs hencoding)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (∑' result, Pr[= result | referenceEncodingLazyRest contactObserver key inputs hencoding outside selections dummy adversary] *
+      (contactMarkerCount key.parameter (referenceFamilyWords selections dummy) result.1.frontier (result.1.before * result.1.after) : ENNReal)) ≤
+      (41 / (Fintype.card Digest : ENNReal)) * ∑' result,
+        Pr[= result | referenceEncodingLazyRest contactObserver key inputs hencoding outside selections dummy adversary] *
+          (contactMarkerCost key.parameter (referenceFamilyWords selections dummy) result.1.frontier 1 (result.1.before * result.1.after) : ENNReal) := by
+  rw [referenceEncodingLazyRest_frontier_statistic key inputs hencoding outside selections dummy adversary
+    (fun frontier trace => (contactMarkerCount key.parameter (referenceFamilyWords selections dummy) frontier trace : ENNReal)),
+    referenceEncodingLazyRest_frontier_statistic key inputs hencoding outside selections dummy adversary
+      (fun frontier trace => (contactMarkerCost key.parameter (referenceFamilyWords selections dummy) frontier 1 trace : ENNReal))]
+  exact EncodingObservation.contactMarker_initial_lazyRun_le key.parameter inputs hencoding outside
+    (outsideGraphMessage key inputs hencoding outside) selections dummy _
+    (referenceEncodingProgram key inputs hencoding outside selections dummy adversary)
+
+private theorem weighted_bound {Value : Type} (law : SPMF Value) (left right : Value → ENNReal) (rate : ENNReal)
+    (h : ∀ value, left value ≤ rate * right value) :
+    (∑' value, Pr[= value | law] * left value) ≤ rate * ∑' value, Pr[= value | law] * right value := by
+  calc
+    _ ≤ ∑' value, Pr[= value | law] * (rate * right value) :=
+      ENNReal.tsum_le_tsum fun value => mul_le_mul' le_rfl (h value)
+    _ = _ := by simp only [mul_left_comm _ rate, ENNReal.tsum_mul_left]
+
+theorem referenceContactGame_contactMarker_count_le (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (∑' result, Pr[= result | referenceContactGame inputs hencoding dummy adversary] *
+      (contactMarkerCount result.1 (referenceFamilyWords result.2.1 dummy) result.2.2.frontier (result.2.2.before * result.2.2.after) : ENNReal)) ≤
+      (41 / (Fintype.card Digest : ENNReal)) * ∑' result,
+        Pr[= result | referenceContactGame inputs hencoding dummy adversary] *
+          (contactMarkerCost result.1 (referenceFamilyWords result.2.1 dummy) result.2.2.frontier 1 (result.2.2.before * result.2.2.after) : ENNReal) := by
+  rw [referenceContactGame, ← referenceEncodingLazyGame_original contactObserver inputs hencoding hgraph dummy adversary]
+  simp only [referenceEncodingLazyGame, tsum_probOutput_bind_mul, tsum_probOutput_map_mul, tsum_probOutput_pure_mul]
+  apply weighted_bound
+  intro parameter
+  apply weighted_bound
+  intro otsSecret
+  apply weighted_bound
+  intro ftsSecret
+  apply weighted_bound
+  intro selections
+  apply weighted_bound
+  intro outside
+  exact referenceEncodingLazyRest_contactMarker_le ⟨parameter, 0, otsSecret, ftsSecret⟩ inputs (hencoding parameter)
+    outside selections dummy adversary
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingContactMarkerStep.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingContactMarkerStep.lean
new file mode 100644
index 000000000..9fccd956f
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingContactMarkerStep.lean
@@ -0,0 +1,59 @@
+import SphincsSecurity.Proof.Ots.OtsContactMarkerTrace
+namespace SphincsSecurity.Concrete.OtsEncodingMarker
+
+open _root_.OracleComp OracleSpec UniformTableCompletion EncodingObservation RetainedObservation
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] Finset.univ canonicalEncodingInputs OtsContactTrace.contacts
+
+theorem contactBeforeEntry_query_le (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (outside : NonencodingRows parameter inputs hencoding)
+    (messages : EncodingPosition → Digest) (selections : ReferenceFamily) (dummy : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (history : OtsContactTrace.Trace) (allowed : canonicalEncodingInputs parameter → Finset HashOutput)
+    (hc : TraceConsistent parameter (referenceEncodingAllowed parameter messages selections) history allowed) (input : HashInput) :
+    Pr[fun result => ContactBeforeEntry parameter (referenceFamilyWords selections dummy) frontier history (input, result.1) |
+      (lazyWorldImpl parameter inputs hencoding outside (.inr input)).run allowed] ≤
+      (41 / (Fintype.card Digest : ENNReal)) * (contactMarkerCharge parameter (referenceFamilyWords selections dummy) frontier history (.inr input) : ENNReal) := by
+  by_cases hi : input ∈ canonicalEncodingInputs parameter
+  · have he : QueryClass.EncodingHash parameter (.inr input) := encodingInput_position parameter input hi
+    simp only [lazyWorldImpl, QueryImpl.compose, translate, dif_pos hi, simulateQ_spec_query,
+      UniformTableObservation.lazyImpl, StateT.run_mk, probEvent_map, Function.comp_def, contactMarkerCharge, if_pos he, ContactBeforeEntry]
+    refine (newMarker_subset_cell_le parameter messages selections dummy history allowed hc
+      (OtsContactTrace.contacts parameter (referenceFamilyWords selections dummy) frontier history) ⟨input, hi⟩).trans_eq ?_
+    simp only [div_eq_mul_inv]
+    ring
+  · have hz : Pr[fun result => ContactBeforeEntry parameter (referenceFamilyWords selections dummy) frontier history (input, result.1) |
+        (lazyWorldImpl parameter inputs hencoding outside (.inr input)).run allowed] = 0 := by
+      apply probEvent_eq_zero
+      rintro result _ ⟨address, _, hm⟩
+      exact hi hm.1.2.1
+    rw [hz]
+    exact bot_le
+
+section Potential
+
+attribute [local instance 10000] Classical.propDecidable
+
+theorem contactMarker_query_potential_le (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (outside : NonencodingRows parameter inputs hencoding)
+    (messages : EncodingPosition → Digest) (selections : ReferenceFamily) (dummy : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (history : OtsContactTrace.Trace) (allowed : canonicalEncodingInputs parameter → Finset HashOutput)
+    (hc : TraceConsistent parameter (referenceEncodingAllowed parameter messages selections) history allowed) (input : OracleWorld.Domain) :
+    (∑' result, Pr[= result | (lazyWorldImpl parameter inputs hencoding outside input).run allowed] *
+      (contactMarkerCount parameter (referenceFamilyWords selections dummy) frontier (history * hashObservationTrace input result.1) : ENNReal)) ≤
+      (contactMarkerCount parameter (referenceFamilyWords selections dummy) frontier history : ENNReal) +
+        (41 / (Fintype.card Digest : ENNReal)) * (contactMarkerCharge parameter (referenceFamilyWords selections dummy) frontier history input : ENNReal) := by
+  cases input with
+  | inl input =>
+      simp only [hashObservationTrace, mul_one, contactMarkerCharge, QueryClass.EncodingHash, if_false,
+        Nat.cast_zero, mul_zero, add_zero, ENNReal.tsum_mul_right]
+      exact mul_le_of_le_one_left zero_le tsum_probOutput_le_one
+  | inr input =>
+      simp only [hashObservationTrace, contactMarkerCount_step, Nat.cast_add, Nat.cast_ite, Nat.cast_one, Nat.cast_zero,
+        mul_add, ENNReal.tsum_add, mul_ite, mul_one, mul_zero, ← probEvent_eq_tsum_ite, ENNReal.tsum_mul_right]
+      exact add_le_add (mul_le_of_le_one_left zero_le tsum_probOutput_le_one)
+        (contactBeforeEntry_query_le parameter inputs hencoding outside messages selections dummy frontier history allowed hc input)
+
+end Potential
+
+end SphincsSecurity.Concrete.OtsEncodingMarker
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingFamilyObservation.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingFamilyObservation.lean
new file mode 100644
index 000000000..0848b5ac1
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingFamilyObservation.lean
@@ -0,0 +1,35 @@
+import SphincsSecurity.Proof.Ots.EncodingConditionalObservation
+import SphincsSecurity.Proof.Base.UniformTableProducts
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec UniformTableCompletion
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] Finset.univ
+
+noncomputable def encodingFamilyAllowed (selections : ReferenceFamily) (row : EncodingRow) : Finset HashOutput :=
+  encodingSelectionAllowed (selections row.1) row.2
+
+theorem encodingFamilyAllowed_nonempty (selections : ReferenceFamily) :
+    ∀ row, (encodingFamilyAllowed selections row).Nonempty :=
+  fun row => encodingSelectionAllowed_nonempty (selections row.1) row.2
+
+theorem encoding_afterSelect_uniform (selection : ReferenceSelection) :
+    FirstSuccessTable.afterSelect decodeEncodingOutput encodingAttemptLimit decodeEncodingOutput_invalid_nonempty selection =
+      uniformTable (encodingSelectionAllowed selection) (encodingSelectionAllowed_nonempty selection) := by
+  apply PMF.ext
+  intro table
+  have h := congrArg (fun law : SPMF (Fin encodingAttemptLimit → HashOutput) => law table)
+    (encoding_afterSelect_complete selection)
+  simpa only [complete_of_nonempty _ (encodingSelectionAllowed_nonempty selection), PMF.evalDist_eq, SPMF.liftM_apply] using h
+
+theorem encoding_family_uniform (selections : ReferenceFamily) :
+    (FirstSuccessFamily.afterSelect decodeEncodingOutput encodingAttemptLimit
+      decodeEncodingOutput_invalid_nonempty selections).map Function.uncurry =
+        uniformTable (encodingFamilyAllowed selections) (encodingFamilyAllowed_nonempty selections) := by
+  simp only [FirstSuccessFamily.afterSelect, encoding_afterSelect_uniform, uniformTable_eq_product]
+  exact FinitePmfProduct.uncurry (fun position coordinate =>
+    PMF.uniformOfFinset (encodingSelectionAllowed (selections position) coordinate)
+      (encodingSelectionAllowed_nonempty (selections position) coordinate))
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingFamilyOracleSplit.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingFamilyOracleSplit.lean
new file mode 100644
index 000000000..85d628f75
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingFamilyOracleSplit.lean
@@ -0,0 +1,64 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Base.FirstSuccessFamily
+import SphincsSecurity.Proof.Reference.ReferenceOracleConditioning
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs
+set_option backward.isDefEq.respectTransparency false
+
+namespace UniformTableSplit
+
+theorem uniform_bind_firstSuccessFamily {Index Cell Answer Value Result : Type}
+    [Fintype Index] [DecidableEq Index] [Fintype Cell] [DecidableEq Cell]
+    [Fintype Answer] [DecidableEq Answer] [Nonempty Answer] [Fintype Value] {n : Nat}
+    (embed : Index × Fin n → Cell) (hinj : Function.Injective embed) (decode : Answer → Option Value)
+    (hinvalid : (FirstSuccessTable.invalid decode).Nonempty)
+    (next : (Index → Option (Fin n × Value)) → (Cell → Answer) → PMF Result) :
+    (PMF.uniformOfFintype (Cell → Answer)).bind (fun table =>
+        next (fun index => FirstSuccessTable.select decode (fun counter => table (embed (index, counter)))) table) =
+      (FirstSuccessFamily.selected decode n).bind (fun results =>
+        (FirstSuccessFamily.afterSelect decode n hinvalid results).bind (fun rows =>
+          (PMF.uniformOfFintype (Outside embed → Answer)).bind
+            (fun outside => next results (join embed hinj (Function.uncurry rows) outside)))) := by
+  rw [uniform_bind_split embed hinj]
+  simp only [join_embed]
+  have huncurry := PMF.uniformOfFintype_map_of_bijective (Equiv.curry Index (Fin n) Answer).symm
+    (Equiv.curry Index (Fin n) Answer).symm.bijective
+  rw [← huncurry, PMF.bind_map]
+  exact FirstSuccessFamily.uniform_bind_eq_selected decode n hinvalid
+    (fun results rows => (PMF.uniformOfFintype (Outside embed → Answer)).bind
+      (fun outside => next results (join embed hinj (Function.uncurry rows) outside)))
+
+end UniformTableSplit
+
+abbrev ReferenceFamily := EncodingPosition → ReferenceSelection
+
+noncomputable def referenceFamilyCell (parameter : PublicParameter) (messages : EncodingPosition → Digest)
+    (row : EncodingRow) : canonicalEncodingInputs parameter :=
+  referenceCounterCell parameter row.1 (messages row.1) row.2
+
+theorem referenceFamilyCell_injective (parameter : PublicParameter) (messages : EncodingPosition → Digest) :
+    Function.Injective (referenceFamilyCell parameter messages) := by
+  rintro ⟨left, first⟩ ⟨right, second⟩ heq
+  have hbytes := congrArg Subtype.val heq
+  have hposition : left = right := atEncodingPosition_unique
+    (show AtEncodingPosition parameter (encodingRetryInput parameter left (messages left) first.val) left from ⟨_, rfl⟩)
+    (show AtEncodingPosition parameter (encodingRetryInput parameter left (messages left) first.val) right from ⟨_, hbytes⟩)
+  subst right
+  exact Prod.ext rfl (referenceCounterCell_injective parameter left (messages left) heq)
+
+noncomputable def referenceFamilyOracleTable (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (outside : NonencodingRows key.parameter inputs hencoding)
+    (rows : EncodingPosition → Fin encodingAttemptLimit → HashOutput)
+    (remaining : UniformTableSplit.Outside
+      (referenceFamilyCell key.parameter (outsideGraphMessage key inputs hencoding outside)) → HashOutput) :
+    inputs → HashOutput :=
+  joinEncodingTable key.parameter inputs hencoding
+    (UniformTableSplit.join
+      (referenceFamilyCell key.parameter (outsideGraphMessage key inputs hencoding outside))
+      (referenceFamilyCell_injective key.parameter (outsideGraphMessage key inputs hencoding outside))
+      (Function.uncurry rows) remaining) outside
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingFreshRow.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingFreshRow.lean
new file mode 100644
index 000000000..e121eaab4
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingFreshRow.lean
@@ -0,0 +1,71 @@
+import SphincsSecurity.Proof.Ots.EncodingNeighborProbability
+import SphincsSecurity.Proof.Ots.ReferenceEncodingTable
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] Finset.univ
+
+def FreshEncodingSupport (reference : Encoding) (allowed : Finset HashOutput) : Prop :=
+  allowed = Finset.univ ∨ ∀ output ∈ allowed, decodeEncodingOutput output = none ∨ decodeEncodingOutput output = some reference
+
+theorem firstSuccess_allowed_fresh {n : Nat} (index : Fin n) (reference : Encoding) (coordinate : Fin n) :
+    FreshEncodingSupport reference (FirstSuccessTable.allowed decodeEncodingOutput index reference coordinate) := by
+  unfold FirstSuccessTable.allowed
+  split_ifs with hlt heq
+  · exact Or.inr fun output ho => Or.inl ((FirstSuccessTable.mem_invalid _ _).mp ho)
+  · exact Or.inr fun output ho => Or.inr ((FirstSuccessTable.mem_fiber _ _ _).mp ho)
+  · exact Or.inl rfl
+
+theorem freshEncodingSupport_probability_le (reference : Encoding) (targets : Finset Encoding) (href : reference ∉ targets)
+    (allowed : Finset HashOutput) (ha : allowed.Nonempty) (hallowed : FreshEncodingSupport reference allowed) :
+    Pr[fun output : HashOutput => truncateHash output ∈ TargetSum.decodingDigests targets | PMF.uniformOfFinset allowed ha] ≤
+      (targets.card : ENNReal) / Fintype.card Digest := by
+  rcases hallowed with rfl | hrestricted
+  · have h := TargetSum.decodingDigests_uniform_le targets
+    simpa only [probEvent_eq_tsum_ite, probOutput_uniformSample, PMF.probOutput_eq_apply, PMF.uniformOfFinset_apply,
+      Finset.mem_univ, if_true, Finset.card_univ] using h
+  · have hzero : Pr[fun output : HashOutput => truncateHash output ∈ TargetSum.decodingDigests targets |
+        PMF.uniformOfFinset allowed ha] = 0 := by
+      simp only [probEvent_eq_tsum_ite, PMF.probOutput_eq_apply]
+      apply ENNReal.tsum_eq_zero.mpr
+      intro output
+      by_cases hm : output ∈ allowed
+      · have hn : truncateHash output ∉ TargetSum.decodingDigests targets := by
+          intro hd
+          obtain ⟨word, hw, hdecode⟩ := TargetSum.mem_decodingDigests.mp hd
+          change decodeEncodingOutput output = some word at hdecode
+          rcases hrestricted output hm with hi | hr
+          · rw [hi] at hdecode
+            contradiction
+          · have he : reference = word := Option.some.inj (hr.symm.trans hdecode)
+            exact href (he ▸ hw)
+        exact if_neg hn
+      · simp only [PMF.uniformOfFinset_apply, if_neg hm, ite_self]
+    rw [hzero]
+    exact zero_le
+
+theorem freshEncodingSupport_neighbor_le (reference : Encoding) (lowered : ChainIndex)
+    (allowed : Finset HashOutput) (ha : allowed.Nonempty) (hallowed : FreshEncodingSupport reference allowed) :
+    Pr[fun output : HashOutput => truncateHash output ∈ TargetSum.decodingDigests (TargetSum.unitNeighbors reference lowered) |
+      PMF.uniformOfFinset allowed ha] ≤ 41 / (Fintype.card Digest : ENNReal) := by
+  have href : reference ∉ TargetSum.unitNeighbors reference lowered := by
+    intro h
+    obtain ⟨raised, ht⟩ := TargetSum.mem_unitNeighbors.mp h
+    exact ht.ne rfl
+  exact (freshEncodingSupport_probability_le reference _ href allowed ha hallowed).trans
+    (ENNReal.div_le_div_right (Nat.cast_le.mpr (TargetSum.unitNeighbors_card_le reference lowered)) _)
+
+theorem freshEncodingSupport_all_neighbors_le (reference : Encoding)
+    (allowed : Finset HashOutput) (ha : allowed.Nonempty) (hallowed : FreshEncodingSupport reference allowed) :
+    Pr[fun output : HashOutput => truncateHash output ∈ TargetSum.decodingDigests (TargetSum.allUnitNeighbors reference) |
+      PMF.uniformOfFinset allowed ha] ≤ 1722 / (Fintype.card Digest : ENNReal) := by
+  have href : reference ∉ TargetSum.allUnitNeighbors reference := by
+    intro h
+    obtain ⟨lowered, raised, ht⟩ := TargetSum.mem_allUnitNeighbors.mp h
+    exact ht.ne rfl
+  exact (freshEncodingSupport_probability_le reference _ href allowed ha hallowed).trans
+    (ENNReal.div_le_div_right (Nat.cast_le.mpr (TargetSum.allUnitNeighbors_card_le reference)) _)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingInputs.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingInputs.lean
new file mode 100644
index 000000000..0737d5abd
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingInputs.lean
@@ -0,0 +1,22 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Ots.EncodingSelectionCache
+namespace SphincsSecurity.Concrete
+
+noncomputable def canonicalEncodingInputs (parameter : PublicParameter) : Finset HashInput :=
+  Finset.univ.biUnion fun position : EncodingPosition =>
+    (Finset.univ : Finset (Digest × Fin encodingAttemptLimit)).image fun pair =>
+      encodingRetryInput parameter position pair.1 pair.2.val
+
+attribute [local irreducible] canonicalEncodingInputs
+
+theorem encodingRetryInput_mem_canonicalEncodingInputs (parameter : PublicParameter) (position : EncodingPosition)
+    (message : Digest) (counter : Fin encodingAttemptLimit) :
+    encodingRetryInput parameter position message counter.val ∈ canonicalEncodingInputs parameter := by
+  classical
+  rw [canonicalEncodingInputs, Finset.mem_biUnion]
+  simp only [Finset.mem_univ, true_and]
+  refine ⟨position, ?_⟩
+  simp only [Finset.mem_image, Finset.mem_univ, true_and]
+  exact ⟨(message, counter), rfl⟩
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingMarkerAccumulation.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingMarkerAccumulation.lean
new file mode 100644
index 000000000..7bad7609b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingMarkerAccumulation.lean
@@ -0,0 +1,107 @@
+import SphincsSecurity.Proof.Ots.EncodingMarkerStep
+import SphincsSecurity.Proof.Base.QueryTracePotential
+
+/-! ## UniformTableObservationMass -/
+
+namespace SphincsSecurity.Concrete.UniformTableObservation
+
+open _root_.OracleComp OracleSpec UniformTableCompletion
+set_option backward.isDefEq.respectTransparency false
+
+theorem lazyRun_neverFail {Coordinate Value AuxIndex Result : Type} [DecidableEq Coordinate]
+    {auxSpec : OracleSpec AuxIndex} (auxiliary : QueryImpl auxSpec SPMF)
+    (haux : ∀ input, NeverFail (auxiliary input))
+    (computation : OracleComp (auxSpec + TableSpec Coordinate Value) Result)
+    (allowed : Coordinate → Finset Value) (ha : ∀ coordinate, (allowed coordinate).Nonempty) :
+    NeverFail (lazyRun auxiliary computation allowed) := by
+  induction computation using OracleComp.inductionOn generalizing allowed with
+  | pure value => rw [lazyRun_pure]; infer_instance
+  | query_bind input next ih =>
+      cases input with
+      | inl input =>
+          simp only [lazyRun_query_bind, lazyImpl, StateT.run_mk, bind_map_left, neverFail_bind_iff]
+          exact ⟨haux input, fun answer _ => ih answer allowed ha⟩
+      | inr coordinate =>
+          simp only [lazyRun_query_bind, lazyImpl, StateT.run_mk, bind_map_left, neverFail_bind_iff]
+          constructor
+          · rw [cell, dif_pos (ha coordinate)]
+            exact ⟨probFailure_of_liftM_PMF _⟩
+          · intro answer _
+            exact ih answer _ (discloseTableValue_nonempty allowed ha coordinate answer)
+
+end SphincsSecurity.Concrete.UniformTableObservation
+
+namespace SphincsSecurity.Concrete.EncodingObservation
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] Finset.univ canonicalEncodingInputs OtsEncodingMarker.markers
+
+theorem lazyRun_neverFail {Result : Type} (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (outside : NonencodingRows parameter inputs hencoding)
+    (computation : OracleComp OracleWorld Result) (allowed : canonicalEncodingInputs parameter → Finset HashOutput)
+    (ha : ∀ row, (allowed row).Nonempty) : NeverFail (lazyRun parameter inputs hencoding outside computation allowed) := by
+  apply UniformTableObservation.lazyRun_neverFail _ _ _ _ ha
+  intro input
+  exact ⟨probFailure_eq_zero (mx := fixedHashWorld (nonencodingAnswer parameter inputs hencoding outside) input)⟩
+
+noncomputable def encodingCalls (parameter : PublicParameter) (trace : OtsContactTrace.Trace) : Nat :=
+  QueryCap.calls (QueryClass.EncodingHash parameter) (trace.toList.map fun entry => .inr entry.1)
+
+theorem encodingCalls_one (parameter : PublicParameter) : encodingCalls parameter 1 = 0 := rfl
+
+theorem encodingCalls_step (parameter : PublicParameter) (input : OracleWorld.Domain) (answer : OracleWorld.Range input)
+    (tail : OtsContactTrace.Trace) :
+    encodingCalls parameter (hashObservationTrace input answer * tail) =
+      (if QueryClass.EncodingHash parameter input then 1 else 0) + encodingCalls parameter tail := by
+  cases input with
+  | inl input => simp only [hashObservationTrace, one_mul, QueryClass.EncodingHash, if_false, Nat.zero_add]
+  | inr input =>
+      simp only [encodingCalls, hashObservationTrace, FreeMonoid.toList_mul, FreeMonoid.toList_of,
+        List.singleton_append, List.map_cons, QueryCap.calls_cons]
+
+theorem markers_lazyRun_le {Result : Type} (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (outside : NonencodingRows parameter inputs hencoding)
+    (messages : EncodingPosition → Digest) (selections : ReferenceFamily) (dummy : OtsReferenceWords)
+    (computation : OracleComp OracleWorld Result) (history : OtsContactTrace.Trace)
+    (allowed : canonicalEncodingInputs parameter → Finset HashOutput)
+    (hc : TraceConsistent parameter (referenceEncodingAllowed parameter messages selections) history allowed)
+    (ha : ∀ row, (allowed row).Nonempty) :
+    (∑' result, Pr[= result | lazyRun parameter inputs hencoding outside (QueryPause.traced hashObservationTrace computation) allowed] *
+      ((OtsEncodingMarker.markers parameter (referenceFamilyWords selections dummy) (history * result.1.2)).card : ENNReal)) ≤
+      ((OtsEncodingMarker.markers parameter (referenceFamilyWords selections dummy) history).card : ENNReal) +
+        (1722 / (Fintype.card Digest : ENNReal)) * ∑' result,
+          Pr[= result | lazyRun parameter inputs hencoding outside (QueryPause.traced hashObservationTrace computation) allowed] *
+            (encodingCalls parameter result.1.2 : ENNReal) := by
+  simp only [lazyRun_eq_simulate]
+  apply QueryPause.traced_spmf_potential_le hashObservationTrace (lazyWorldImpl parameter inputs hencoding outside)
+    (fun history allowed => TraceConsistent parameter (referenceEncodingAllowed parameter messages selections) history allowed ∧
+      ∀ row, (allowed row).Nonempty)
+    _ _ (fun history _ => (OtsEncodingMarker.markers parameter (referenceFamilyWords selections dummy) history).card)
+    _ (encodingCalls parameter) _ (encodingCalls_one parameter) (encodingCalls_step parameter) _ computation history allowed ⟨hc, ha⟩
+  · intro history allowed hi input result hr
+    exact ⟨lazyWorldImpl_traceConsistent parameter inputs hencoding outside _ allowed history hi.1 input result hr,
+      UniformTableObservation.lazyRun_nonempty (auxiliary parameter inputs hencoding outside) (translate parameter input)
+        allowed hi.2 result hr⟩
+  · intro computation history allowed hi
+    rw [← lazyRun_eq_simulate]
+    exact probFailure_eq_zero' (lazyRun_neverFail parameter inputs hencoding outside _ allowed hi.2)
+  · intro history allowed hi input
+    exact OtsEncodingMarker.markers_query_potential_le parameter inputs hencoding outside messages selections dummy history allowed hi.1 input
+
+theorem markers_initial_lazyRun_le {Result : Type} (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (outside : NonencodingRows parameter inputs hencoding)
+    (messages : EncodingPosition → Digest) (selections : ReferenceFamily) (dummy : OtsReferenceWords)
+    (computation : OracleComp OracleWorld Result) :
+    (∑' result, Pr[= result | lazyRun parameter inputs hencoding outside (QueryPause.traced hashObservationTrace computation)
+      (referenceEncodingAllowed parameter messages selections)] *
+      ((OtsEncodingMarker.markers parameter (referenceFamilyWords selections dummy) result.1.2).card : ENNReal)) ≤
+        (1722 / (Fintype.card Digest : ENNReal)) * ∑' result,
+          Pr[= result | lazyRun parameter inputs hencoding outside (QueryPause.traced hashObservationTrace computation)
+            (referenceEncodingAllowed parameter messages selections)] * (encodingCalls parameter result.1.2 : ENNReal) := by
+  simpa only [one_mul, OtsEncodingMarker.markers_one, Finset.card_empty, Nat.cast_zero, zero_add] using
+    markers_lazyRun_le parameter inputs hencoding outside messages selections dummy computation 1 _
+      (traceConsistent_one parameter _) (referenceEncodingAllowed_nonempty parameter messages selections)
+
+end SphincsSecurity.Concrete.EncodingObservation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingMarkerAllocation.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingMarkerAllocation.lean
new file mode 100644
index 000000000..e45ea98f6
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingMarkerAllocation.lean
@@ -0,0 +1,71 @@
+import SphincsSecurity.Proof.Ots.EncodingMarkerBound
+import SphincsSecurity.Proof.Reference.ReferenceQueryAllocation
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalGraphInputs canonicalEncodingInputs canonicalGraphGameInputs Finset.univ
+
+theorem contactObserver_encodingCalls (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (computation : OracleComp OracleWorld (Bool × SigningBoundaryTrace)) :
+    (fun result : ContactResult => (result.output, EncodingObservation.encodingCalls parameter (result.before * result.after))) <$>
+      contactObserver parameter words frontier computation = QueryCap.counted (QueryClass.EncodingHash parameter) computation := by
+  have h := congrArg (Functor.map (fun result => (result.1, EncodingObservation.encodingCalls parameter result.2)))
+    (contactObserver_trace parameter words frontier computation)
+  rw [Functor.map_map] at h
+  exact h.trans (QueryPause.traced_counted hashObservationTrace (QueryClass.EncodingHash parameter)
+    (EncodingObservation.encodingCalls parameter) (EncodingObservation.encodingCalls_one parameter)
+    (EncodingObservation.encodingCalls_step parameter) computation)
+
+theorem referenceContactRest_encodingCalls (key : SecretKey) (oracle : QueryImpl HashSpec Id)
+    (labels : CanonicalGraphLabels) (selections : ReferenceFamily) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (fun result : ContactResult => (result.output, EncodingObservation.encodingCalls key.parameter (result.before * result.after))) <$>
+      referenceInstrumentedRest contactObserver key oracle labels selections dummy adversary =
+        (fun result => (result.1, QueryCap.calls (QueryClass.EncodingHash key.parameter) result.2)) <$>
+          referenceRecordedRest key oracle labels selections dummy adversary := by
+  rw [referenceInstrumentedRest, referenceRecordedRest, ← simulateQ_map, ← simulateQ_map,
+    contactObserver_encodingCalls, QueryCap.recorded_counted]
+
+theorem referenceContactGame_encodingCalls (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (fun result : InstrumentedResult ContactResult =>
+      (result.1, result.2.1, result.2.2.output, EncodingObservation.encodingCalls result.1 (result.2.2.before * result.2.2.after))) <$>
+        referenceContactGame inputs hencoding dummy adversary =
+      (fun result : ReferenceRecordedResult => (result.1, result.2.1, result.2.2.1, result.encodingCalls)) <$>
+        referenceRecordedGame inputs hencoding dummy adversary := by
+  unfold referenceContactGame referenceInstrumentedGame referenceRecordedGame
+  simp only [map_bind, map_pure, ReferenceRecordedResult.encodingCalls]
+  apply congrArg (𝒟[sampleParameter] >>= ·)
+  funext parameter
+  apply congrArg (𝒟[sampleOtsSecrets] >>= ·)
+  funext otsSecret
+  apply congrArg (𝒟[sampleFtsSecrets] >>= ·)
+  funext ftsSecret
+  apply congrArg (𝒟[referenceFamilyOracleSample _ inputs (hencoding parameter)] >>= ·)
+  funext reference
+  have h := congrArg (fun law => (fun result => (parameter, reference.1, result.1, result.2)) <$> 𝒟[law])
+    (referenceContactRest_encodingCalls ⟨parameter, 0, otsSecret, ftsSecret⟩ (finiteHashAnswer ∅ inputs reference.2)
+      (canonicalGraphLabels parameter otsSecret ftsSecret (finiteHashAnswer ∅ inputs reference.2)) reference.1 dummy adversary)
+  simpa only [← bind_pure_comp, evalDist_bind, evalDist_pure, bind_assoc, pure_bind] using h
+
+theorem referenceContactGame_expected_encodingCalls (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (∑' result, Pr[= result | referenceContactGame inputs hencoding dummy adversary] *
+      (EncodingObservation.encodingCalls result.1 (result.2.2.before * result.2.2.after) : ENNReal)) =
+        ∑' result, Pr[= result | referenceRecordedGame inputs hencoding dummy adversary] * (result.encodingCalls : ENNReal) := by
+  have h := congrArg (fun law : SPMF (PublicParameter × ReferenceFamily × (Bool × SigningBoundaryTrace) × Nat) =>
+    ∑' result, Pr[= result | law] * (result.2.2.2 : ENNReal)) (referenceContactGame_encodingCalls inputs hencoding dummy adversary)
+  simpa only [tsum_probOutput_map_mul] using h
+
+theorem referenceContactGame_markers_le_encodingCost (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (∑' result, Pr[= result | referenceContactGame (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] *
+      ((OtsEncodingMarker.markers result.1 (referenceFamilyWords result.2.1 dummy)
+        (result.2.2.before * result.2.2.after)).card : ENNReal)) ≤
+      (1722 / (Fintype.card Digest : ENNReal)) * ∑' result,
+        Pr[= result | referenceRecordedGame (canonicalGraphGameInputs adversary)
+          (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] * (result.encodingCalls : ENNReal) := by
+  rw [← referenceContactGame_expected_encodingCalls]
+  exact referenceContactGame_markers_le _ _ (canonicalGraphInputs_subset_gameInputs adversary) dummy adversary
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingMarkerBound.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingMarkerBound.lean
new file mode 100644
index 000000000..21e8f2518
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingMarkerBound.lean
@@ -0,0 +1,76 @@
+import SphincsSecurity.Proof.Ots.EncodingMarkerAccumulation
+import SphincsSecurity.Proof.Ots.ReferenceEncodingLazySource
+import SphincsSecurity.Proof.Reference.ReferenceContactGame
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalGraphInputs canonicalEncodingInputs Finset.univ OtsEncodingMarker.markers
+
+theorem contactObserver_trace (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (computation : OracleComp OracleWorld (Bool × SigningBoundaryTrace)) :
+    (fun result : ContactResult => (result.output, result.before * result.after)) <$>
+      contactObserver parameter words frontier computation = QueryPause.traced hashObservationTrace computation := by
+  simpa only [contactObserver, Functor.map_map] using OtsContactTrace.splitRun_trace parameter words frontier computation
+
+theorem referenceEncodingLazyRest_contact_trace (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (outside : NonencodingRows key.parameter inputs hencoding)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (fun result => ((result.1.output, result.1.before * result.1.after), result.2)) <$>
+      referenceEncodingLazyRest contactObserver key inputs hencoding outside selections dummy adversary =
+        EncodingObservation.lazyRun key.parameter inputs hencoding outside
+          (QueryPause.traced hashObservationTrace (referenceEncodingProgram key inputs hencoding outside selections dummy adversary))
+          (referenceEncodingAllowed key.parameter (outsideGraphMessage key inputs hencoding outside) selections) := by
+  rw [referenceEncodingLazyRest,
+    ← EncodingObservation.lazyRun_map (f := fun result : ContactResult => (result.output, result.before * result.after)),
+    contactObserver_trace]
+
+theorem referenceEncodingLazyRest_markers_le (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (outside : NonencodingRows key.parameter inputs hencoding)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (∑' result, Pr[= result | referenceEncodingLazyRest contactObserver key inputs hencoding outside selections dummy adversary] *
+      ((OtsEncodingMarker.markers key.parameter (referenceFamilyWords selections dummy) (result.1.before * result.1.after)).card : ENNReal)) ≤
+      (1722 / (Fintype.card Digest : ENNReal)) * ∑' result,
+        Pr[= result | referenceEncodingLazyRest contactObserver key inputs hencoding outside selections dummy adversary] *
+          (EncodingObservation.encodingCalls key.parameter (result.1.before * result.1.after) : ENNReal) := by
+  have h := EncodingObservation.markers_initial_lazyRun_le key.parameter inputs hencoding outside
+    (outsideGraphMessage key inputs hencoding outside) selections dummy
+    (referenceEncodingProgram key inputs hencoding outside selections dummy adversary)
+  rw [← referenceEncodingLazyRest_contact_trace key inputs hencoding outside selections dummy adversary,
+    tsum_probOutput_map_mul, tsum_probOutput_map_mul] at h
+  exact h
+
+private theorem weighted_bound {Value : Type} (law : SPMF Value) (left right : Value → ENNReal) (rate : ENNReal)
+    (h : ∀ value, left value ≤ rate * right value) :
+    (∑' value, Pr[= value | law] * left value) ≤ rate * ∑' value, Pr[= value | law] * right value := by
+  calc
+    _ ≤ ∑' value, Pr[= value | law] * (rate * right value) :=
+      ENNReal.tsum_le_tsum fun value => mul_le_mul' le_rfl (h value)
+    _ = _ := by simp only [mul_left_comm _ rate, ENNReal.tsum_mul_left]
+
+theorem referenceContactGame_markers_le (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (∑' result, Pr[= result | referenceContactGame inputs hencoding dummy adversary] *
+      ((OtsEncodingMarker.markers result.1 (referenceFamilyWords result.2.1 dummy)
+        (result.2.2.before * result.2.2.after)).card : ENNReal)) ≤
+      (1722 / (Fintype.card Digest : ENNReal)) * ∑' result,
+        Pr[= result | referenceContactGame inputs hencoding dummy adversary] *
+          (EncodingObservation.encodingCalls result.1 (result.2.2.before * result.2.2.after) : ENNReal) := by
+  rw [referenceContactGame, ← referenceEncodingLazyGame_original contactObserver inputs hencoding hgraph dummy adversary]
+  simp only [referenceEncodingLazyGame, tsum_probOutput_bind_mul, tsum_probOutput_map_mul, tsum_probOutput_pure_mul]
+  apply weighted_bound
+  intro parameter
+  apply weighted_bound
+  intro otsSecret
+  apply weighted_bound
+  intro ftsSecret
+  apply weighted_bound
+  intro selections
+  apply weighted_bound
+  intro outside
+  exact referenceEncodingLazyRest_markers_le ⟨parameter, 0, otsSecret, ftsSecret⟩ inputs (hencoding parameter)
+    outside selections dummy adversary
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingMarkerKernel.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingMarkerKernel.lean
new file mode 100644
index 000000000..70a9850e4
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingMarkerKernel.lean
@@ -0,0 +1,55 @@
+import SphincsSecurity.Proof.Ots.EncodingTablePrior
+import SphincsSecurity.Proof.Ots.OtsEncodingMarker
+namespace SphincsSecurity.Concrete.OtsEncodingMarker
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] Finset.univ canonicalEncodingInputs
+
+theorem entryMarker_allowed_le (parameter : PublicParameter) (messages : EncodingPosition → Digest)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords) (address : OtsPrefix.ChainAddress)
+    (cell : canonicalEncodingInputs parameter) :
+    Pr[fun output : HashOutput => EntryMarker parameter (referenceFamilyWords selections dummy) address (cell.val, output) |
+      PMF.uniformOfFinset (referenceEncodingAllowed parameter messages selections cell)
+        (referenceEncodingAllowed_nonempty parameter messages selections cell)] ≤ 41 / (Fintype.card Digest : ENNReal) := by
+  by_cases hp : AtEncodingPosition parameter cell.val ⟨address.1, address.2.1, address.2.2.1⟩
+  · refine (_root_.probEvent_mono (mx := (liftM (PMF.uniformOfFinset (referenceEncodingAllowed parameter messages selections cell)
+      (referenceEncodingAllowed_nonempty parameter messages selections cell)) : SPMF HashOutput)) ?_).trans (freshEncodingSupport_neighbor_le
+      (referenceFamilyWords selections dummy address.1 address.2.1 address.2.2.1) address.2.2.2 _ _
+      (referenceEncodingAllowed_fresh parameter messages selections dummy cell _ hp))
+    intro output _ hm
+    obtain ⟨_, _, candidate, hd, hn⟩ := hm
+    exact TargetSum.mem_decodingDigests.mpr ⟨candidate, TargetSum.mem_unitNeighbors.mpr hn, hd⟩
+  · have he : (fun output : HashOutput => EntryMarker parameter (referenceFamilyWords selections dummy) address (cell.val, output)) =
+        fun _ => False := by
+      funext output
+      apply propext
+      exact ⟨fun hm => hp hm.1, False.elim⟩
+    rw [he]
+    simp only [probEvent_eq_tsum_ite, if_false, tsum_zero, zero_le]
+
+theorem encodingInput_position (parameter : PublicParameter) (input : HashInput)
+    (hc : input ∈ canonicalEncodingInputs parameter) : ∃ position, AtEncodingPosition parameter input position := by
+  rw [canonicalEncodingInputs] at hc
+  simp only [Finset.mem_biUnion, Finset.mem_univ, true_and, Finset.mem_image] at hc
+  obtain ⟨position, pair, hinput⟩ := hc
+  exact ⟨position, _, hinput.symm⟩
+
+theorem entryMarker_any_allowed_le (parameter : PublicParameter) (messages : EncodingPosition → Digest)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords) (cell : canonicalEncodingInputs parameter) :
+    Pr[fun output : HashOutput => ∃ address, EntryMarker parameter (referenceFamilyWords selections dummy) address (cell.val, output) |
+      PMF.uniformOfFinset (referenceEncodingAllowed parameter messages selections cell)
+        (referenceEncodingAllowed_nonempty parameter messages selections cell)] ≤ 1722 / (Fintype.card Digest : ENNReal) := by
+  obtain ⟨position, hp⟩ := encodingInput_position parameter cell.val cell.property
+  refine (_root_.probEvent_mono (mx := (liftM (PMF.uniformOfFinset (referenceEncodingAllowed parameter messages selections cell)
+      (referenceEncodingAllowed_nonempty parameter messages selections cell)) : SPMF HashOutput)) ?_).trans (freshEncodingSupport_all_neighbors_le
+    (referenceFamilyWords selections dummy position.lay position.tree position.leafIdx) _ _
+    (referenceEncodingAllowed_fresh parameter messages selections dummy cell position hp))
+  intro output _ hm
+  obtain ⟨⟨lay, tree, leaf, chain⟩, hposition, _, candidate, hd, hn⟩ := hm
+  have he := atEncodingPosition_unique hposition hp
+  subst position
+  exact TargetSum.mem_decodingDigests.mpr ⟨candidate, TargetSum.mem_allUnitNeighbors.mpr ⟨chain, hn⟩, hd⟩
+
+end SphincsSecurity.Concrete.OtsEncodingMarker
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingMarkerStep.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingMarkerStep.lean
new file mode 100644
index 000000000..76ad9f60a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingMarkerStep.lean
@@ -0,0 +1,82 @@
+import SphincsSecurity.Proof.Ots.EncodingAdaptiveMarker
+namespace SphincsSecurity.Concrete.OtsEncodingMarker
+
+open _root_.OracleComp OracleSpec UniformTableCompletion EncodingObservation RetainedObservation
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] Finset.univ canonicalEncodingInputs markers
+
+def QueryNewMarker (parameter : PublicParameter) (words : OtsReferenceWords) (history : OtsContactTrace.Trace)
+    (input : OracleWorld.Domain) (answer : OracleWorld.Range input) : Prop :=
+  ∃ address, Seen parameter words address (history * hashObservationTrace input answer) ∧ ¬Seen parameter words address history
+
+theorem queryNewMarker_coin (parameter : PublicParameter) (words : OtsReferenceWords) (history : OtsContactTrace.Trace)
+    (input : unifSpec.Domain) (answer : unifSpec.Range input) : ¬QueryNewMarker parameter words history (.inl input) answer := by
+  simp only [QueryNewMarker, hashObservationTrace, mul_one, and_not_self, exists_false, not_false_eq_true]
+
+theorem queryNewMarker_hash (parameter : PublicParameter) (words : OtsReferenceWords) (history : OtsContactTrace.Trace)
+    (input : HashInput) (output : HashOutput) :
+    QueryNewMarker parameter words history (.inr input) output ↔ ∃ address, NewMarker parameter words history address (input, output) := by
+  simp only [QueryNewMarker, hashObservationTrace, seen_mul, seen_of, or_and_right, and_not_self, false_or, NewMarker]
+
+theorem queryNewMarker_any_le (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (outside : NonencodingRows parameter inputs hencoding)
+    (messages : EncodingPosition → Digest) (selections : ReferenceFamily) (dummy : OtsReferenceWords)
+    (history : OtsContactTrace.Trace) (allowed : canonicalEncodingInputs parameter → Finset HashOutput)
+    (hc : TraceConsistent parameter (referenceEncodingAllowed parameter messages selections) history allowed)
+    (input : OracleWorld.Domain) :
+    Pr[fun result => QueryNewMarker parameter (referenceFamilyWords selections dummy) history input result.1 |
+      (lazyWorldImpl parameter inputs hencoding outside input).run allowed] ≤
+      (1722 / (Fintype.card Digest : ENNReal)) * ((if QueryClass.EncodingHash parameter input then 1 else 0 : Nat) : ENNReal) := by
+  cases input with
+  | inl input =>
+      have hz : Pr[fun result => QueryNewMarker parameter (referenceFamilyWords selections dummy) history (.inl input) result.1 |
+          (lazyWorldImpl parameter inputs hencoding outside (.inl input)).run allowed] = 0 :=
+        probEvent_eq_zero fun result _ => queryNewMarker_coin _ _ _ _ result.1
+      rw [hz]
+      exact bot_le
+  | inr input =>
+      by_cases hi : input ∈ canonicalEncodingInputs parameter
+      · have he : QueryClass.EncodingHash parameter (.inr input) := encodingInput_position parameter input hi
+        simp only [lazyWorldImpl, QueryImpl.compose, translate, dif_pos hi, simulateQ_spec_query,
+          UniformTableObservation.lazyImpl, StateT.run_mk, probEvent_map, Function.comp_def,
+          queryNewMarker_hash, if_pos he, Nat.cast_one, mul_one]
+        exact newMarker_any_cell_le parameter messages selections dummy history allowed hc ⟨input, hi⟩
+      · have hz : Pr[fun result => QueryNewMarker parameter (referenceFamilyWords selections dummy) history (.inr input) result.1 |
+            (lazyWorldImpl parameter inputs hencoding outside (.inr input)).run allowed] = 0 := by
+          apply probEvent_eq_zero
+          intro result _ hm
+          obtain ⟨_, hm⟩ := (queryNewMarker_hash _ _ _ _ _).mp hm
+          exact hi hm.1.2.1
+        rw [hz]
+        exact bot_le
+
+section Potential
+
+attribute [local instance 10000] Classical.propDecidable
+
+theorem markers_query_potential_le (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (outside : NonencodingRows parameter inputs hencoding)
+    (messages : EncodingPosition → Digest) (selections : ReferenceFamily) (dummy : OtsReferenceWords)
+    (history : OtsContactTrace.Trace) (allowed : canonicalEncodingInputs parameter → Finset HashOutput)
+    (hc : TraceConsistent parameter (referenceEncodingAllowed parameter messages selections) history allowed)
+    (input : OracleWorld.Domain) :
+    (∑' result, Pr[= result | (lazyWorldImpl parameter inputs hencoding outside input).run allowed] *
+      ((markers parameter (referenceFamilyWords selections dummy) (history * hashObservationTrace input result.1)).card : ENNReal)) ≤
+      ((markers parameter (referenceFamilyWords selections dummy) history).card : ENNReal) +
+        (1722 / (Fintype.card Digest : ENNReal)) * ((if QueryClass.EncodingHash parameter input then 1 else 0 : Nat) : ENNReal) := by
+  cases input with
+  | inl input =>
+      simp only [hashObservationTrace, mul_one, QueryClass.EncodingHash, if_false, Nat.cast_zero,
+        mul_zero, add_zero, ENNReal.tsum_mul_right]
+      exact mul_le_of_le_one_left zero_le tsum_probOutput_le_one
+  | inr input =>
+      simp only [hashObservationTrace, markers_step_card, Nat.cast_add, Nat.cast_ite, Nat.cast_one, Nat.cast_zero,
+        mul_add, ENNReal.tsum_add, mul_ite, mul_one, mul_zero, ← probEvent_eq_tsum_ite, ENNReal.tsum_mul_right]
+      apply add_le_add (mul_le_of_le_one_left zero_le tsum_probOutput_le_one)
+      simpa only [queryNewMarker_hash, Nat.cast_ite, Nat.cast_one, Nat.cast_zero, mul_ite, mul_one, mul_zero] using
+        queryNewMarker_any_le parameter inputs hencoding outside messages selections dummy history allowed hc (.inr input)
+
+end Potential
+
+end SphincsSecurity.Concrete.OtsEncodingMarker
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingMatchAccumulation.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingMatchAccumulation.lean
new file mode 100644
index 000000000..cc646954f
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingMatchAccumulation.lean
@@ -0,0 +1,151 @@
+import SphincsSecurity.Proof.Ots.EncodingMatchKernel
+import SphincsSecurity.Proof.Ots.EncodingMarkerAccumulation
+import SphincsSecurity.Proof.Ots.ReferenceLayerWitness
+namespace SphincsSecurity.Concrete.OtsVerifierWitness
+
+open _root_.OracleComp OracleSpec UniformTableCompletion EncodingObservation
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] Finset.univ canonicalEncodingInputs
+
+variable (parameter : PublicParameter) (words : OtsReferenceWords)
+  (messages : EncodingPosition → Digest) (selections : ReferenceFamily)
+
+theorem encodingOutputMatch_one : ¬EncodingOutputMatch parameter words messages selections 1 := by
+  simp [EncodingOutputMatch]
+
+theorem encodingOutputMatch_of (entry : HashInput × HashOutput) :
+    EncodingOutputMatch parameter words messages selections (FreeMonoid.of entry) ↔
+      entry.1 ∈ canonicalEncodingInputs parameter ∧ PublicEncodingMatch.Match parameter messages words selections entry.1 entry.2 := by
+  simp [EncodingOutputMatch]
+
+theorem encodingOutputMatch_mul (before after : OtsContactTrace.Trace) :
+    EncodingOutputMatch parameter words messages selections (before * after) ↔
+      EncodingOutputMatch parameter words messages selections before ∨ EncodingOutputMatch parameter words messages selections after := by
+  simp only [EncodingOutputMatch, FreeMonoid.toList_mul, List.mem_append, or_and_right, exists_or]
+
+theorem newEncodingMatch_cell_le (history : OtsContactTrace.Trace)
+    (allowed : canonicalEncodingInputs parameter → Finset HashOutput)
+    (hc : TraceConsistent parameter (referenceEncodingAllowed parameter messages selections) history allowed)
+    (row : canonicalEncodingInputs parameter) :
+    Pr[fun output => PublicEncodingMatch.Match parameter messages words selections row.val output ∧
+      ¬EncodingOutputMatch parameter words messages selections history | cell (allowed row)] ≤ (Fintype.card Digest : ENNReal)⁻¹ := by
+  refine (_root_.probEvent_mono (fun _ _ h => ⟨h.1, fun hin => h.2 ⟨_, hin, row.property, h.1⟩⟩)).trans
+    ((hc.new_reply_probability_le row (PublicEncodingMatch.Match parameter messages words selections row.val)).trans ?_)
+  simpa only [cell, dif_pos (referenceEncodingAllowed_nonempty parameter messages selections row), SPMF.probEvent_liftM] using
+    PublicEncodingMatch.match_allowed_le parameter messages words selections row
+
+def QueryNewEncodingMatch (history : OtsContactTrace.Trace) (input : OracleWorld.Domain) (answer : OracleWorld.Range input) : Prop :=
+  EncodingOutputMatch parameter words messages selections (history * hashObservationTrace input answer) ∧
+    ¬EncodingOutputMatch parameter words messages selections history
+
+theorem queryNewEncodingMatch_coin (history : OtsContactTrace.Trace) (input : unifSpec.Domain) (answer : unifSpec.Range input) :
+    ¬QueryNewEncodingMatch parameter words messages selections history (.inl input) answer := by
+  simp only [QueryNewEncodingMatch, hashObservationTrace, mul_one, and_not_self, not_false_eq_true]
+
+theorem queryNewEncodingMatch_hash (history : OtsContactTrace.Trace) (input : HashInput) (output : HashOutput) :
+    QueryNewEncodingMatch parameter words messages selections history (.inr input) output ↔
+      (input ∈ canonicalEncodingInputs parameter ∧ PublicEncodingMatch.Match parameter messages words selections input output) ∧
+        ¬EncodingOutputMatch parameter words messages selections history := by
+  simp only [QueryNewEncodingMatch, hashObservationTrace, encodingOutputMatch_mul, encodingOutputMatch_of,
+    or_and_right, and_not_self, false_or]
+
+theorem queryNewEncodingMatch_le (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (outside : NonencodingRows parameter inputs hencoding)
+    (history : OtsContactTrace.Trace) (allowed : canonicalEncodingInputs parameter → Finset HashOutput)
+    (hc : TraceConsistent parameter (referenceEncodingAllowed parameter messages selections) history allowed)
+    (input : OracleWorld.Domain) :
+    Pr[fun result => QueryNewEncodingMatch parameter words messages selections history input result.1 |
+      (lazyWorldImpl parameter inputs hencoding outside input).run allowed] ≤
+      (Fintype.card Digest : ENNReal)⁻¹ * ((if QueryClass.EncodingHash parameter input then 1 else 0 : Nat) : ENNReal) := by
+  cases input with
+  | inl input =>
+      have hz : Pr[fun result => QueryNewEncodingMatch parameter words messages selections history (.inl input) result.1 |
+          (lazyWorldImpl parameter inputs hencoding outside (.inl input)).run allowed] = 0 :=
+        probEvent_eq_zero fun result _ => queryNewEncodingMatch_coin _ _ _ _ _ _ result.1
+      rw [hz]
+      exact bot_le
+  | inr input =>
+      by_cases hi : input ∈ canonicalEncodingInputs parameter
+      · have he : QueryClass.EncodingHash parameter (.inr input) := OtsEncodingMarker.encodingInput_position parameter input hi
+        simp only [lazyWorldImpl, QueryImpl.compose, translate, dif_pos hi, simulateQ_spec_query,
+          UniformTableObservation.lazyImpl, StateT.run_mk, probEvent_map, Function.comp_def,
+          queryNewEncodingMatch_hash, if_pos he, Nat.cast_one, mul_one]
+        simp only [hi, true_and]
+        exact newEncodingMatch_cell_le parameter words messages selections history allowed hc ⟨input, hi⟩
+      · have hz : Pr[fun result => QueryNewEncodingMatch parameter words messages selections history (.inr input) result.1 |
+            (lazyWorldImpl parameter inputs hencoding outside (.inr input)).run allowed] = 0 := by
+          apply probEvent_eq_zero
+          intro result _ hm
+          exact hi ((queryNewEncodingMatch_hash _ _ _ _ _ _ _).mp hm).1.1
+        rw [hz]
+        exact bot_le
+
+theorem encodingMatch_query_potential_le (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (outside : NonencodingRows parameter inputs hencoding)
+    (history : OtsContactTrace.Trace) (allowed : canonicalEncodingInputs parameter → Finset HashOutput)
+    (hc : TraceConsistent parameter (referenceEncodingAllowed parameter messages selections) history allowed)
+    (input : OracleWorld.Domain) :
+    (∑' result, Pr[= result | (lazyWorldImpl parameter inputs hencoding outside input).run allowed] *
+      (if EncodingOutputMatch parameter words messages selections (history * hashObservationTrace input result.1) then 1 else 0 : ENNReal)) ≤
+      (if EncodingOutputMatch parameter words messages selections history then 1 else 0 : ENNReal) +
+        (Fintype.card Digest : ENNReal)⁻¹ * ((if QueryClass.EncodingHash parameter input then 1 else 0 : Nat) : ENNReal) := by
+  by_cases hs : EncodingOutputMatch parameter words messages selections history
+  · have hnext : ∀ answer, EncodingOutputMatch parameter words messages selections (history * hashObservationTrace input answer) :=
+      fun _ => (encodingOutputMatch_mul _ _ _ _ _ _).mpr (Or.inl hs)
+    simp only [if_pos hs, if_pos (hnext _), mul_one]
+    exact le_add_of_le_left tsum_probOutput_le_one
+  · simpa only [QueryNewEncodingMatch, hs, not_false_eq_true, and_true, if_false, zero_add,
+      probEvent_eq_tsum_ite, mul_ite, mul_one, mul_zero] using
+      queryNewEncodingMatch_le parameter words messages selections inputs hencoding outside history allowed hc input
+
+theorem encodingMatch_lazyRun_le {Result : Type} (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (outside : NonencodingRows parameter inputs hencoding)
+    (computation : OracleComp OracleWorld Result) (history : OtsContactTrace.Trace)
+    (allowed : canonicalEncodingInputs parameter → Finset HashOutput)
+    (hc : TraceConsistent parameter (referenceEncodingAllowed parameter messages selections) history allowed)
+    (ha : ∀ row, (allowed row).Nonempty) :
+    Pr[fun result => EncodingOutputMatch parameter words messages selections (history * result.1.2) |
+      lazyRun parameter inputs hencoding outside (QueryPause.traced hashObservationTrace computation) allowed] ≤
+      (if EncodingOutputMatch parameter words messages selections history then 1 else 0 : ENNReal) +
+        (Fintype.card Digest : ENNReal)⁻¹ * ∑' result,
+          Pr[= result | lazyRun parameter inputs hencoding outside (QueryPause.traced hashObservationTrace computation) allowed] *
+            (encodingCalls parameter result.1.2 : ENNReal) := by
+  suffices h : (∑' result, Pr[= result | lazyRun parameter inputs hencoding outside
+      (QueryPause.traced hashObservationTrace computation) allowed] *
+      (if EncodingOutputMatch parameter words messages selections (history * result.1.2) then 1 else 0 : ENNReal)) ≤
+      (if EncodingOutputMatch parameter words messages selections history then 1 else 0 : ENNReal) +
+        (Fintype.card Digest : ENNReal)⁻¹ * ∑' result,
+          Pr[= result | lazyRun parameter inputs hencoding outside (QueryPause.traced hashObservationTrace computation) allowed] *
+            (encodingCalls parameter result.1.2 : ENNReal) by
+    simpa only [mul_ite, mul_one, mul_zero, ← probEvent_eq_tsum_ite] using h
+  simp only [lazyRun_eq_simulate]
+  apply QueryPause.traced_spmf_potential_le hashObservationTrace (lazyWorldImpl parameter inputs hencoding outside)
+    (fun history allowed => TraceConsistent parameter (referenceEncodingAllowed parameter messages selections) history allowed ∧
+      ∀ row, (allowed row).Nonempty)
+    _ _ (fun history _ => if EncodingOutputMatch parameter words messages selections history then 1 else 0)
+    _ (encodingCalls parameter) _ (encodingCalls_one parameter) (encodingCalls_step parameter) _ computation history allowed ⟨hc, ha⟩
+  · intro history allowed hi input result hr
+    exact ⟨lazyWorldImpl_traceConsistent parameter inputs hencoding outside _ allowed history hi.1 input result hr,
+      UniformTableObservation.lazyRun_nonempty (auxiliary parameter inputs hencoding outside) (translate parameter input)
+        allowed hi.2 result hr⟩
+  · intro computation history allowed hi
+    rw [← lazyRun_eq_simulate]
+    exact probFailure_eq_zero' (lazyRun_neverFail parameter inputs hencoding outside _ allowed hi.2)
+  · intro history allowed hi input
+    exact encodingMatch_query_potential_le parameter words messages selections inputs hencoding outside history allowed hi.1 input
+
+theorem encodingMatch_initial_lazyRun_le {Result : Type} (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (outside : NonencodingRows parameter inputs hencoding)
+    (computation : OracleComp OracleWorld Result) :
+    Pr[fun result => EncodingOutputMatch parameter words messages selections result.1.2 |
+      lazyRun parameter inputs hencoding outside (QueryPause.traced hashObservationTrace computation)
+        (referenceEncodingAllowed parameter messages selections)] ≤
+      (Fintype.card Digest : ENNReal)⁻¹ * ∑' result,
+        Pr[= result | lazyRun parameter inputs hencoding outside (QueryPause.traced hashObservationTrace computation)
+          (referenceEncodingAllowed parameter messages selections)] * (encodingCalls parameter result.1.2 : ENNReal) := by
+  simpa only [one_mul, if_neg (encodingOutputMatch_one parameter words messages selections), zero_add] using
+    encodingMatch_lazyRun_le parameter words messages selections inputs hencoding outside computation 1 _
+      (traceConsistent_one parameter _) (referenceEncodingAllowed_nonempty parameter messages selections)
+
+end SphincsSecurity.Concrete.OtsVerifierWitness
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingMatchBound.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingMatchBound.lean
new file mode 100644
index 000000000..48cae346f
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingMatchBound.lean
@@ -0,0 +1,82 @@
+import SphincsSecurity.Proof.Ots.EncodingMatchAccumulation
+import SphincsSecurity.Proof.Ots.ReferenceEncodingContext
+import SphincsSecurity.Proof.Ots.EncodingMarkerAllocation
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphInputs canonicalEncodingInputs canonicalGraphGameInputs Finset.univ
+
+theorem referenceEncodingLazyRest_match_le (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (outside : NonencodingRows key.parameter inputs hencoding)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    Pr[fun result => OtsVerifierWitness.EncodingOutputMatch key.parameter (referenceFamilyWords selections dummy)
+      (outsideGraphMessage key inputs hencoding outside) selections (result.1.before * result.1.after) |
+        referenceEncodingLazyRest contactObserver key inputs hencoding outside selections dummy adversary] ≤
+      (Fintype.card Digest : ENNReal)⁻¹ * ∑' result,
+        Pr[= result | referenceEncodingLazyRest contactObserver key inputs hencoding outside selections dummy adversary] *
+          (EncodingObservation.encodingCalls key.parameter (result.1.before * result.1.after) : ENNReal) := by
+  have h := OtsVerifierWitness.encodingMatch_initial_lazyRun_le key.parameter (referenceFamilyWords selections dummy)
+    (outsideGraphMessage key inputs hencoding outside) selections inputs hencoding outside
+    (referenceEncodingProgram key inputs hencoding outside selections dummy adversary)
+  rw [← referenceEncodingLazyRest_contact_trace key inputs hencoding outside selections dummy adversary,
+    probEvent_map, tsum_probOutput_map_mul] at h
+  exact h
+
+private theorem weighted_bound {Value : Type} (law : SPMF Value) (left right : Value → ENNReal) (rate : ENNReal)
+    (h : ∀ value, left value ≤ rate * right value) :
+    (∑' value, Pr[= value | law] * left value) ≤ rate * ∑' value, Pr[= value | law] * right value := by
+  calc
+    _ ≤ ∑' value, Pr[= value | law] * (rate * right value) :=
+      ENNReal.tsum_le_tsum fun value => mul_le_mul' le_rfl (h value)
+    _ = _ := by simp only [mul_left_comm _ rate, ENNReal.tsum_mul_left]
+
+theorem referenceEncodingContextGame_match_le (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    Pr[fun result => OtsVerifierWitness.EncodingOutputMatch result.1 (referenceFamilyWords result.2.1 dummy)
+      result.2.2.1 result.2.1 (result.2.2.2.before * result.2.2.2.after) |
+        referenceEncodingContextGame contactObserver inputs hencoding dummy adversary] ≤
+      (Fintype.card Digest : ENNReal)⁻¹ * ∑' result,
+        Pr[= result | referenceEncodingContextGame contactObserver inputs hencoding dummy adversary] *
+          (EncodingObservation.encodingCalls result.1 (result.2.2.2.before * result.2.2.2.after) : ENNReal) := by
+  rw [referenceEncodingContextGame_lazy contactObserver inputs hencoding hgraph dummy adversary]
+  simp only [probEvent_bind_eq_tsum, probEvent_pure,
+    tsum_probOutput_bind_mul, tsum_probOutput_map_mul, tsum_probOutput_pure_mul]
+  apply weighted_bound
+  intro parameter
+  apply weighted_bound
+  intro otsSecret
+  apply weighted_bound
+  intro ftsSecret
+  apply weighted_bound
+  intro selections
+  apply weighted_bound
+  intro outside
+  simpa only [probEvent_pure, mul_ite, mul_one, mul_zero, probEvent_eq_tsum_ite] using
+    referenceEncodingLazyRest_match_le ⟨parameter, 0, otsSecret, ftsSecret⟩ inputs (hencoding parameter) outside selections dummy adversary
+
+theorem referenceEncodingContextGame_expected_encodingCalls (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (∑' result, Pr[= result | referenceEncodingContextGame contactObserver inputs hencoding dummy adversary] *
+      (EncodingObservation.encodingCalls result.1 (result.2.2.2.before * result.2.2.2.after) : ENNReal)) =
+        ∑' result, Pr[= result | referenceRecordedGame inputs hencoding dummy adversary] * (result.encodingCalls : ENNReal) := by
+  have h := congrArg (fun law : SPMF (InstrumentedResult ContactResult) =>
+    ∑' result, Pr[= result | law] * (EncodingObservation.encodingCalls result.1 (result.2.2.before * result.2.2.after) : ENNReal))
+      (referenceEncodingContextGame_erased contactObserver inputs hencoding dummy adversary)
+  rw [tsum_probOutput_map_mul] at h
+  exact h.trans (referenceContactGame_expected_encodingCalls inputs hencoding dummy adversary)
+
+theorem referenceEncodingContextGame_match_le_encodingCost (dummy : OtsReferenceWords) (adversary : Adversary) :
+    Pr[fun result => OtsVerifierWitness.EncodingOutputMatch result.1 (referenceFamilyWords result.2.1 dummy)
+      result.2.2.1 result.2.1 (result.2.2.2.before * result.2.2.2.after) |
+        referenceEncodingContextGame contactObserver (canonicalGraphGameInputs adversary)
+          (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] ≤
+      (Fintype.card Digest : ENNReal)⁻¹ * ∑' result,
+        Pr[= result | referenceRecordedGame (canonicalGraphGameInputs adversary)
+          (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] * (result.encodingCalls : ENNReal) := by
+  rw [← referenceEncodingContextGame_expected_encodingCalls]
+  exact referenceEncodingContextGame_match_le _ _ (canonicalGraphInputs_subset_gameInputs adversary) dummy adversary
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingMatchKernel.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingMatchKernel.lean
new file mode 100644
index 000000000..b2602268f
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingMatchKernel.lean
@@ -0,0 +1,81 @@
+import SphincsSecurity.Proof.Ots.PublicEncodingMatch
+import SphincsSecurity.Proof.Ots.EncodingTablePrior
+namespace SphincsSecurity.Concrete.PublicEncodingMatch
+
+open _root_.OracleComp OracleSpec UniformTableCompletion
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] Finset.univ canonicalEncodingInputs canonicalGraphInputs
+set_option backward.isDefEq.respectTransparency false
+
+theorem reference_cell_not_match (parameter : PublicParameter) (messages : EncodingPosition → Digest)
+    (words : OtsReferenceWords) (selections : ReferenceFamily) (row : EncodingRow) (word : Encoding)
+    (hselected : selections row.1 = some (row.2, word)) (answer : HashOutput) :
+    ¬Match parameter messages words selections (referenceFamilyCell parameter messages row).val answer := by
+  rintro ⟨position, hat, hnonreference, _⟩
+  have hp : AtEncodingPosition parameter (referenceFamilyCell parameter messages row).val row.1 := ⟨_, rfl⟩
+  obtain rfl := atEncodingPosition_unique hat hp
+  apply hnonreference
+  rw [referenceInput, hselected]
+  rfl
+
+theorem match_allowed_cases (parameter : PublicParameter) (messages : EncodingPosition → Digest)
+    (words : OtsReferenceWords) (selections : ReferenceFamily) (cell : canonicalEncodingInputs parameter) :
+    referenceEncodingAllowed parameter messages selections cell = Finset.univ ∨
+      ∀ answer ∈ referenceEncodingAllowed parameter messages selections cell,
+        ¬Match parameter messages words selections cell.val answer := by
+  by_cases hc : cell ∈ Set.range (referenceFamilyCell parameter messages)
+  · obtain ⟨row, rfl⟩ := hc
+    rw [referenceEncodingAllowed, UniformTableSplit.join_embed, encodingFamilyAllowed]
+    cases hs : selections row.1 with
+    | none =>
+        right
+        intro answer ha hm
+        have hi := (FirstSuccessTable.mem_invalid decodeEncodingOutput answer).mp ha
+        obtain ⟨_, _, _, hd⟩ := hm
+        rw [hi] at hd
+        contradiction
+    | some selected =>
+        obtain ⟨index, word⟩ := selected
+        simp only [encodingSelectionAllowed]
+        split_ifs with hfiber
+        · rw [FirstSuccessTable.allowed]
+          split_ifs with hlt heq
+          · right
+            intro answer ha hm
+            have hi := (FirstSuccessTable.mem_invalid decodeEncodingOutput answer).mp ha
+            obtain ⟨_, _, _, hd⟩ := hm
+            rw [hi] at hd
+            contradiction
+          · right
+            intro answer _
+            apply reference_cell_not_match parameter messages words selections row word ?_ answer
+            simpa only [heq] using hs
+          · exact Or.inl rfl
+        · exact Or.inl rfl
+  · left
+    exact UniformTableSplit.join_outside (referenceFamilyCell parameter messages)
+      (referenceFamilyCell_injective parameter messages) (encodingFamilyAllowed selections) (fun _ => Finset.univ)
+      (⟨cell, hc⟩ : UniformTableSplit.Outside (referenceFamilyCell parameter messages))
+
+theorem match_allowed_le (parameter : PublicParameter) (messages : EncodingPosition → Digest)
+    (words : OtsReferenceWords) (selections : ReferenceFamily) (cell : canonicalEncodingInputs parameter) :
+    Pr[Match parameter messages words selections cell.val |
+      PMF.uniformOfFinset (referenceEncodingAllowed parameter messages selections cell)
+        (referenceEncodingAllowed_nonempty parameter messages selections cell)] ≤ (Fintype.card Digest : ENNReal)⁻¹ := by
+  rcases match_allowed_cases parameter messages words selections cell with hfull | hnone
+  · simpa only [probEvent_eq_tsum_ite, PMF.probOutput_eq_apply, PMF.uniformOfFinset_apply,
+      hfull, Finset.mem_univ, if_true, Finset.card_univ, SPMF.probOutput_liftM, PMF.uniformOfFintype_apply] using
+      prob_match_le parameter messages words selections cell.val
+  · have hz : Pr[Match parameter messages words selections cell.val |
+        PMF.uniformOfFinset (referenceEncodingAllowed parameter messages selections cell)
+          (referenceEncodingAllowed_nonempty parameter messages selections cell)] = 0 := by
+      simp only [probEvent_eq_tsum_ite, PMF.probOutput_eq_apply]
+      apply ENNReal.tsum_eq_zero.mpr
+      intro answer
+      by_cases ha : answer ∈ referenceEncodingAllowed parameter messages selections cell
+      · exact if_neg (hnone answer ha)
+      · simp only [PMF.uniformOfFinset_apply, if_neg ha, ite_self]
+    rw [hz]
+    exact bot_le
+
+end SphincsSecurity.Concrete.PublicEncodingMatch
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingNeighborProbability.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingNeighborProbability.lean
new file mode 100644
index 000000000..85e7db352
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingNeighborProbability.lean
@@ -0,0 +1,42 @@
+import SphincsSecurity.Proof.Ots.EncodingNeighbors
+import SphincsSecurity.Proof.Ots.EncodingProbability
+namespace SphincsSecurity.TargetSum
+
+open _root_.OracleComp OracleSpec ENNReal
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] Finset.univ
+
+theorem digestEncoding_of_decode_some {digest : Digest} {word : Encoding}
+    (h : decodeDigest digest = some word) : digestEncoding digest = word := by
+  rw [decodeDigest] at h
+  split at h
+  · exact Option.some.inj h
+  · contradiction
+
+noncomputable def decodingDigests (words : Finset Encoding) : Finset Digest :=
+  Finset.univ.filter fun digest => ∃ word ∈ words, decodeDigest digest = some word
+
+theorem mem_decodingDigests {words : Finset Encoding} {digest : Digest} :
+    digest ∈ decodingDigests words ↔ ∃ word ∈ words, decodeDigest digest = some word := by
+  simp only [decodingDigests, Finset.mem_filter, Finset.mem_univ, true_and]
+
+theorem decodingDigests_card_le (words : Finset Encoding) : (decodingDigests words).card ≤ words.card := by
+  apply Finset.card_le_card_of_injOn digestEncoding
+  · intro digest hd
+    obtain ⟨word, hw, hdecode⟩ := mem_decodingDigests.mp hd
+    rwa [digestEncoding_of_decode_some hdecode]
+  · intro left hl right hr he
+    obtain ⟨leftWord, _, hleft⟩ := mem_decodingDigests.mp hl
+    obtain ⟨rightWord, _, hright⟩ := mem_decodingDigests.mp hr
+    have hw : leftWord = rightWord := (digestEncoding_of_decode_some hleft).symm.trans
+      (he.trans (digestEncoding_of_decode_some hright))
+    exact decodeDigest_some_injective (hw ▸ hleft) hright
+
+theorem decodingDigests_uniform_le (words : Finset Encoding) :
+    Pr[fun output : HashOutput => truncateHash output ∈ decodingDigests words | ($ᵗ HashOutput : ProbComp HashOutput)] ≤
+      (words.card : ENNReal) / Fintype.card Digest := by
+  rw [probEvent_uniform_truncateHash_mem]
+  exact ENNReal.div_le_div_right (Nat.cast_le.mpr (decodingDigests_card_le words)) _
+
+end SphincsSecurity.TargetSum
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingNeighbors.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingNeighbors.lean
new file mode 100644
index 000000000..3fcd5def5
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingNeighbors.lean
@@ -0,0 +1,97 @@
+import SphincsSecurity.Proof.Scheme.Code
+namespace SphincsSecurity.TargetSum
+
+open scoped BigOperators
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] Finset.univ
+
+def UnitTransfer (reference candidate : Encoding) (lowered raised : ChainIndex) : Prop :=
+  lowered ≠ raised ∧ (candidate lowered).val + 1 = (reference lowered).val ∧
+    (reference raised).val + 1 = (candidate raised).val ∧
+    ∀ index, index ≠ lowered → index ≠ raised → candidate index = reference index
+
+def UnitNeighborAt (reference candidate : Encoding) (lowered : ChainIndex) : Prop :=
+  ∃ raised, UnitTransfer reference candidate lowered raised
+
+theorem UnitTransfer.candidate_unique {reference left right : Encoding} {lowered raised : ChainIndex}
+    (hleft : UnitTransfer reference left lowered raised) (hright : UnitTransfer reference right lowered raised) : left = right := by
+  funext index
+  by_cases hl : index = lowered
+  · subst index
+    apply Fin.ext
+    have := hleft.2.1
+    have := hright.2.1
+    omega
+  · by_cases hr : index = raised
+    · subst index
+      apply Fin.ext
+      exact hleft.2.2.1.symm.trans hright.2.2.1
+    · exact (hleft.2.2.2 index hl hr).trans (hright.2.2.2 index hl hr).symm
+
+theorem UnitTransfer.lowered_unique {reference candidate : Encoding} {lowered raised otherLowered otherRaised : ChainIndex}
+    (h : UnitTransfer reference candidate lowered raised) (hother : UnitTransfer reference candidate otherLowered otherRaised) :
+    lowered = otherLowered := by
+  by_contra hne
+  have hd := h.2.1
+  by_cases hr : lowered = otherRaised
+  · subst otherRaised
+    have := hother.2.2.1
+    omega
+  · have he := hother.2.2.2 lowered hne hr
+    rw [he] at hd
+    omega
+
+theorem UnitTransfer.ne {reference candidate : Encoding} {lowered raised : ChainIndex}
+    (h : UnitTransfer reference candidate lowered raised) : candidate ≠ reference := by
+  intro he
+  have hd := h.2.1
+  rw [he] at hd
+  omega
+
+theorem UnitNeighborAt.lowered_unique {reference candidate : Encoding} {left right : ChainIndex}
+    (hleft : UnitNeighborAt reference candidate left) (hright : UnitNeighborAt reference candidate right) : left = right := by
+  obtain ⟨raised, hleft⟩ := hleft
+  obtain ⟨otherRaised, hright⟩ := hright
+  exact hleft.lowered_unique hright
+
+noncomputable def unitNeighbors (reference : Encoding) (lowered : ChainIndex) : Finset Encoding :=
+  Finset.univ.filter (fun candidate => UnitNeighborAt reference candidate lowered)
+
+theorem mem_unitNeighbors {reference candidate : Encoding} {lowered : ChainIndex} :
+    candidate ∈ unitNeighbors reference lowered ↔ UnitNeighborAt reference candidate lowered := by
+  simp only [unitNeighbors, Finset.mem_filter, Finset.mem_univ, true_and]
+
+theorem unitNeighbors_card_le (reference : Encoding) (lowered : ChainIndex) : (unitNeighbors reference lowered).card ≤ 41 := by
+  let chooseRaised : {candidate // UnitNeighborAt reference candidate lowered} → {raised : ChainIndex // raised ≠ lowered} :=
+    fun candidate => ⟨candidate.property.choose, candidate.property.choose_spec.1.symm⟩
+  have hinj : Function.Injective chooseRaised := by
+    intro left right he
+    apply Subtype.ext
+    have he' := congrArg Subtype.val he
+    change left.property.choose = right.property.choose at he'
+    apply left.property.choose_spec.candidate_unique
+    rw [he']
+    exact right.property.choose_spec
+  have hcard := Fintype.card_le_of_injective chooseRaised hinj
+  rw [Fintype.card_subtype, Fintype.card_subtype] at hcard
+  have hr : (Finset.univ.filter fun raised : ChainIndex => raised ≠ lowered) = Finset.univ.erase lowered := by
+    ext raised
+    simp only [Finset.mem_filter, Finset.mem_univ, true_and, Finset.mem_erase, and_true]
+  rw [hr, Finset.card_erase_of_mem (Finset.mem_univ lowered), Finset.card_univ] at hcard
+  simpa only [unitNeighbors, Fintype.card_fin, numChains] using hcard
+
+noncomputable def allUnitNeighbors (reference : Encoding) : Finset Encoding :=
+  Finset.univ.biUnion (unitNeighbors reference)
+
+theorem mem_allUnitNeighbors {reference candidate : Encoding} :
+    candidate ∈ allUnitNeighbors reference ↔ ∃ lowered, UnitNeighborAt reference candidate lowered := by
+  simp only [allUnitNeighbors, Finset.mem_biUnion, Finset.mem_univ, true_and, mem_unitNeighbors]
+
+theorem allUnitNeighbors_card_le (reference : Encoding) : (allUnitNeighbors reference).card ≤ 1722 := by
+  calc
+    _ ≤ ∑ lowered : ChainIndex, (unitNeighbors reference lowered).card := Finset.card_biUnion_le
+    _ ≤ ∑ _lowered : ChainIndex, 41 := Finset.sum_le_sum fun lowered _ => unitNeighbors_card_le reference lowered
+    _ = 1722 := by simp only [Finset.sum_const, Finset.card_univ, Fintype.card_fin, numChains, smul_eq_mul]
+
+end SphincsSecurity.TargetSum
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingOracleObservation.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingOracleObservation.lean
new file mode 100644
index 000000000..1676ddc27
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingOracleObservation.lean
@@ -0,0 +1,72 @@
+import SphincsSecurity.Proof.Ots.EncodingTablePrior
+import SphincsSecurity.Proof.Ots.ReferenceEncodingErasure
+import SphincsSecurity.Proof.Base.UniformTableObservationErasure
+namespace SphincsSecurity.Concrete.EncodingObservation
+
+open _root_.OracleComp OracleSpec UniformTableCompletion
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs Finset.univ
+
+abbrev World (parameter : PublicParameter) :=
+  OracleWorld + UniformTableObservation.TableSpec (canonicalEncodingInputs parameter) HashOutput
+
+noncomputable def translate (parameter : PublicParameter) : QueryImpl OracleWorld (OracleComp (World parameter))
+  | .inl input => liftM ((World parameter).query (.inl (.inl input)))
+  | .inr input =>
+      if h : input ∈ canonicalEncodingInputs parameter then liftM ((World parameter).query (.inr ⟨input, h⟩))
+      else liftM ((World parameter).query (.inl (.inr input)))
+
+noncomputable def auxiliary (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (outside : NonencodingRows parameter inputs hencoding) :
+    QueryImpl OracleWorld SPMF := fun input => 𝒟[fixedHashWorld (nonencodingAnswer parameter inputs hencoding outside) input]
+
+theorem fixed_translate (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (outside : NonencodingRows parameter inputs hencoding)
+    (encoding : canonicalEncodingInputs parameter → HashOutput) (input : OracleWorld.Domain) :
+    simulateQ (UniformTableObservation.fixedImpl (auxiliary parameter inputs hencoding outside) encoding) (translate parameter input) =
+      𝒟[fixedHashWorld (finiteHashAnswer ∅ inputs (joinEncodingTable parameter inputs hencoding encoding outside)) input] := by
+  cases input with
+  | inl input =>
+      simp only [translate, simulateQ_spec_query, UniformTableObservation.fixedImpl, auxiliary, fixedHashWorld]
+  | inr input =>
+      by_cases hc : input ∈ canonicalEncodingInputs parameter
+      · have hrow : finiteHashAnswer ∅ inputs (joinEncodingTable parameter inputs hencoding encoding outside) input = encoding ⟨input, hc⟩ := by
+          rw [finiteHashAnswer_none ∅ inputs _ _ (hencoding hc) (by simp)]
+          exact UniformTableSplit.join_embed (encodingInputCell parameter inputs hencoding)
+            (encodingInputCell_injective parameter inputs hencoding) encoding outside ⟨input, hc⟩
+        simp only [translate, dif_pos hc, simulateQ_spec_query, UniformTableObservation.fixedImpl, fixedHashWorld,
+          evalDist_pure, hrow]
+      · have hrow := joinEncodingTable_agrees_outside parameter inputs hencoding encoding (fun _ => 0) outside input hc
+        simp only [translate, dif_neg hc, simulateQ_spec_query, UniformTableObservation.fixedImpl, auxiliary, fixedHashWorld,
+          evalDist_pure, hrow, nonencodingAnswer]
+
+theorem fixed_run {Result : Type} (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (outside : NonencodingRows parameter inputs hencoding)
+    (encoding : canonicalEncodingInputs parameter → HashOutput) (computation : OracleComp OracleWorld Result) :
+    simulateQ (UniformTableObservation.fixedImpl (auxiliary parameter inputs hencoding outside) encoding)
+        (simulateQ (translate parameter) computation) =
+      𝒟[simulateQ (fixedHashWorld (finiteHashAnswer ∅ inputs (joinEncodingTable parameter inputs hencoding encoding outside))) computation] := by
+  induction computation using OracleComp.inductionOn with
+  | pure result => simp only [simulateQ_pure, evalDist_pure]
+  | query_bind input next ih =>
+      simp only [simulateQ_bind, simulateQ_spec_query, evalDist_bind, ih, fixed_translate]
+
+noncomputable def lazyRun {Result : Type} (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (outside : NonencodingRows parameter inputs hencoding)
+    (computation : OracleComp OracleWorld Result) (allowed : canonicalEncodingInputs parameter → Finset HashOutput) :
+    SPMF (Result × (canonicalEncodingInputs parameter → Finset HashOutput)) :=
+  UniformTableObservation.lazyRun (auxiliary parameter inputs hencoding outside) (simulateQ (translate parameter) computation) allowed
+
+theorem lazyRun_original {Result : Type} (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (outside : NonencodingRows parameter inputs hencoding)
+    (computation : OracleComp OracleWorld Result) (allowed : canonicalEncodingInputs parameter → Finset HashOutput)
+    (ha : ∀ cell, (allowed cell).Nonempty) :
+    (complete allowed >>= fun encoding =>
+      𝒟[simulateQ (fixedHashWorld (finiteHashAnswer ∅ inputs (joinEncodingTable parameter inputs hencoding encoding outside))) computation]) =
+        Prod.fst <$> lazyRun parameter inputs hencoding outside computation allowed := by
+  have h := UniformTableObservation.run_marginal (auxiliary parameter inputs hencoding outside)
+    (simulateQ (translate parameter) computation) allowed ha
+  simpa only [fixed_run, lazyRun] using h
+
+end SphincsSecurity.Concrete.EncodingObservation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingOracleSplit.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingOracleSplit.lean
new file mode 100644
index 000000000..066d30b80
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingOracleSplit.lean
@@ -0,0 +1,92 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Ots.CanonicalEncodingSampling
+import SphincsSecurity.Proof.Hypertree.CanonicalGraphSampling
+import SphincsSecurity.Proof.Base.UniformTableSplit
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def encodingInputCell (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (input : canonicalEncodingInputs parameter) : inputs :=
+  Set.inclusion hencoding input
+
+theorem encodingInputCell_injective (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) : Function.Injective (encodingInputCell parameter inputs hencoding) := by
+  exact Set.inclusion_injective hencoding
+
+abbrev NonencodingRows (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) :=
+  UniformTableSplit.Outside (encodingInputCell parameter inputs hencoding) → HashOutput
+
+noncomputable def joinEncodingTable (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (encoding : canonicalEncodingInputs parameter → HashOutput)
+    (outside : NonencodingRows parameter inputs hencoding) : inputs → HashOutput :=
+  UniformTableSplit.join (encodingInputCell parameter inputs hencoding)
+    (encodingInputCell_injective parameter inputs hencoding) encoding outside
+
+noncomputable def nonencodingAnswer (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (outside : NonencodingRows parameter inputs hencoding) :
+    QueryImpl HashSpec Id := finiteHashAnswer ∅ inputs (joinEncodingTable parameter inputs hencoding (fun _ => 0) outside)
+
+theorem canonicalGraphInput_not_encodingInputs (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (position : Position) (labels : CanonicalGraphLabels) :
+    canonicalGraphInput parameter otsSecret ftsSecret position labels ∉ canonicalEncodingInputs parameter := by
+  intro h
+  rw [canonicalEncodingInputs] at h
+  simp only [Finset.mem_biUnion, Finset.mem_univ, true_and, Finset.mem_image] at h
+  obtain ⟨encodingPosition, pair, heq⟩ := h
+  have hencoding : AtEncodingPosition parameter (canonicalGraphInput parameter otsSecret ftsSecret position labels)
+      encodingPosition := ⟨_, heq.symm⟩
+  exact hencoding.not_atPosition position ⟨_, rfl⟩
+
+theorem canonicalGraphCell_not_encodingRange (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (hgraph : canonicalGraphInputs parameter ⊆ inputs)
+    (position : Position) (labels : CanonicalGraphLabels) :
+    canonicalGraphCell parameter otsSecret ftsSecret inputs hgraph position labels ∉
+      Set.range (encodingInputCell parameter inputs hencoding) := by
+  exact UniformTableSplit.inclusion_not_range hencoding
+    (canonicalGraphCell parameter otsSecret ftsSecret inputs hgraph position labels)
+    (canonicalGraphInput_not_encodingInputs parameter otsSecret ftsSecret position labels)
+
+theorem canonicalGraphLabels_joinEncodingTable (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (hgraph : canonicalGraphInputs parameter ⊆ inputs)
+    (encoding : canonicalEncodingInputs parameter → HashOutput) (outside : NonencodingRows parameter inputs hencoding) :
+    canonicalGraphLabels parameter otsSecret ftsSecret
+        (finiteHashAnswer ∅ inputs (joinEncodingTable parameter inputs hencoding encoding outside)) =
+      canonicalGraphLabels parameter otsSecret ftsSecret (nonencodingAnswer parameter inputs hencoding outside) := by
+  apply FiniteGraphSampling.read_congr
+  intro position labels
+  have hrow := hgraph (canonicalGraphInput_mem parameter otsSecret ftsSecret position labels)
+  rw [finiteHashAnswer_none ∅ inputs _ _ hrow (by simp), nonencodingAnswer,
+    finiteHashAnswer_none ∅ inputs _ _ hrow (by simp)]
+  let cell : UniformTableSplit.Outside (encodingInputCell parameter inputs hencoding) :=
+    ⟨canonicalGraphCell parameter otsSecret ftsSecret inputs hgraph position labels,
+      canonicalGraphCell_not_encodingRange parameter otsSecret ftsSecret inputs hencoding hgraph position labels⟩
+  exact (UniformTableSplit.join_outside _ _ encoding outside cell).trans
+    (UniformTableSplit.join_outside _ _ (fun _ => 0) outside cell).symm
+
+noncomputable def referenceCounterCell (parameter : PublicParameter) (position : EncodingPosition) (message : Digest)
+    (counter : Fin encodingAttemptLimit) : canonicalEncodingInputs parameter :=
+  ⟨encodingRetryInput parameter position message counter.val,
+    encodingRetryInput_mem_canonicalEncodingInputs parameter position message counter⟩
+
+theorem referenceCounterCell_injective (parameter : PublicParameter) (position : EncodingPosition) (message : Digest) :
+    Function.Injective (referenceCounterCell parameter position message) := by
+  intro left right heq
+  exact Fin.ext (encodingRetryInput_injective_of_lt left.isLt right.isLt (congrArg Subtype.val heq))
+
+noncomputable def outsideGraphMessage (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (outside : NonencodingRows key.parameter inputs hencoding)
+    (position : EncodingPosition) : Digest :=
+  canonicalGraphMessage (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret
+    (nonencodingAnswer key.parameter inputs hencoding outside)) position
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingProbability.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingProbability.lean
new file mode 100644
index 000000000..2d33776f2
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingProbability.lean
@@ -0,0 +1,45 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.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]
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingSelectionCache.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingSelectionCache.lean
new file mode 100644
index 000000000..9f4f7806a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingSelectionCache.lean
@@ -0,0 +1,37 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Ots.EncodingCharge
+import SphincsSecurity.Proof.Ots.EncodingProbability
+/-!
+# 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))
+
+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
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingTablePrior.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingTablePrior.lean
new file mode 100644
index 000000000..cac2ffbb5
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingTablePrior.lean
@@ -0,0 +1,59 @@
+import SphincsSecurity.Proof.Ots.EncodingFamilyObservation
+import SphincsSecurity.Proof.Base.UniformTableJoin
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec UniformTableCompletion
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] Finset.univ canonicalEncodingInputs UniformTableSplit.join
+
+noncomputable def referenceEncodingAllowed (parameter : PublicParameter) (messages : EncodingPosition → Digest)
+    (selections : ReferenceFamily) : canonicalEncodingInputs parameter → Finset HashOutput :=
+  UniformTableSplit.join (referenceFamilyCell parameter messages) (referenceFamilyCell_injective parameter messages)
+    (encodingFamilyAllowed selections) (fun _ => Finset.univ)
+
+theorem referenceEncodingAllowed_nonempty (parameter : PublicParameter) (messages : EncodingPosition → Digest)
+    (selections : ReferenceFamily) : ∀ cell, (referenceEncodingAllowed parameter messages selections cell).Nonempty :=
+  UniformTableSplit.join_nonempty _ _ _ _ (encodingFamilyAllowed_nonempty selections) (fun _ => Finset.univ_nonempty)
+
+noncomputable def referenceEncodingPrior (parameter : PublicParameter) (messages : EncodingPosition → Digest)
+    (selections : ReferenceFamily) : PMF (canonicalEncodingInputs parameter → HashOutput) :=
+  (FirstSuccessFamily.afterSelect decodeEncodingOutput encodingAttemptLimit decodeEncodingOutput_invalid_nonempty selections).bind
+    (fun rows => (PMF.uniformOfFintype (UniformTableSplit.Outside (referenceFamilyCell parameter messages) → HashOutput)).map
+      (UniformTableSplit.join (referenceFamilyCell parameter messages) (referenceFamilyCell_injective parameter messages)
+        (Function.uncurry rows)))
+
+theorem referenceEncodingPrior_uniform (parameter : PublicParameter) (messages : EncodingPosition → Digest)
+    (selections : ReferenceFamily) :
+    referenceEncodingPrior parameter messages selections =
+      uniformTable (referenceEncodingAllowed parameter messages selections)
+        (referenceEncodingAllowed_nonempty parameter messages selections) := by
+  have h := UniformTableSplit.uniformTable_join (referenceFamilyCell parameter messages)
+    (referenceFamilyCell_injective parameter messages) (encodingFamilyAllowed selections) (fun _ => Finset.univ)
+    (encodingFamilyAllowed_nonempty selections) (fun _ => Finset.univ_nonempty)
+  rw [uniformTable_univ, ← encoding_family_uniform selections, PMF.bind_map] at h
+  exact h
+
+theorem referenceEncodingPrior_complete (parameter : PublicParameter) (messages : EncodingPosition → Digest)
+    (selections : ReferenceFamily) :
+    𝒟[referenceEncodingPrior parameter messages selections] = complete (referenceEncodingAllowed parameter messages selections) := by
+  rw [referenceEncodingPrior_uniform, complete_of_nonempty _ (referenceEncodingAllowed_nonempty parameter messages selections)]
+
+theorem referenceEncodingAllowed_fresh (parameter : PublicParameter) (messages : EncodingPosition → Digest)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords) (cell : canonicalEncodingInputs parameter)
+    (position : EncodingPosition) (hposition : AtEncodingPosition parameter cell.val position) :
+    FreshEncodingSupport (referenceFamilyWords selections dummy position.lay position.tree position.leafIdx)
+      (referenceEncodingAllowed parameter messages selections cell) := by
+  by_cases hc : cell ∈ Set.range (referenceFamilyCell parameter messages)
+  · obtain ⟨row, rfl⟩ := hc
+    have hp := atEncodingPosition_unique hposition
+      (show AtEncodingPosition parameter (referenceFamilyCell parameter messages row).val row.1 from ⟨_, rfl⟩)
+    subst position
+    rw [referenceEncodingAllowed, UniformTableSplit.join_embed]
+    exact encodingSelectionAllowed_fresh (selections row.1) (dummy row.1.lay row.1.tree row.1.leafIdx) row.2
+  · have hrow := UniformTableSplit.join_outside (referenceFamilyCell parameter messages)
+      (referenceFamilyCell_injective parameter messages) (encodingFamilyAllowed selections) (fun _ => (Finset.univ : Finset HashOutput))
+      (⟨cell, hc⟩ : UniformTableSplit.Outside (referenceFamilyCell parameter messages))
+    exact Or.inl hrow
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingTarget.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingTarget.lean
new file mode 100644
index 000000000..8ff94352a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingTarget.lean
@@ -0,0 +1,80 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Ots.EncodingCached
+import SphincsSecurity.Proof.Scheme.ForgeryClassify
+/-!
+# 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
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingTraceCache.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingTraceCache.lean
new file mode 100644
index 000000000..286dd47a2
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/EncodingTraceCache.lean
@@ -0,0 +1,154 @@
+import SphincsSecurity.Proof.Ots.EncodingOracleObservation
+import SphincsSecurity.Proof.Ots.OtsEncodingMarker
+import SphincsSecurity.Proof.Base.QueryTraceInvariant
+namespace SphincsSecurity.Concrete.EncodingObservation
+
+open _root_.OracleComp OracleSpec UniformTableCompletion RetainedObservation
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs Finset.univ
+
+def TraceConsistent (parameter : PublicParameter)
+    (initial : canonicalEncodingInputs parameter → Finset HashOutput) (trace : OtsContactTrace.Trace)
+    (allowed : canonicalEncodingInputs parameter → Finset HashOutput) : Prop :=
+  (∀ cell output, (cell.val, output) ∈ trace.toList → allowed cell = {output}) ∧
+    ∀ cell, (∀ output, (cell.val, output) ∉ trace.toList) → allowed cell = initial cell
+
+theorem traceConsistent_one (parameter : PublicParameter)
+    (initial : canonicalEncodingInputs parameter → Finset HashOutput) :
+    TraceConsistent parameter initial 1 initial := by
+  constructor
+  · simp
+  · intros; rfl
+
+theorem TraceConsistent.outside {parameter : PublicParameter}
+    {initial allowed : canonicalEncodingInputs parameter → Finset HashOutput} {trace : OtsContactTrace.Trace}
+    (h : TraceConsistent parameter initial trace allowed) (input : HashInput)
+    (houtside : input ∉ canonicalEncodingInputs parameter) (output : HashOutput) :
+    TraceConsistent parameter initial (trace * FreeMonoid.of (input, output)) allowed := by
+  constructor
+  · intro cell answer hentry
+    simp only [FreeMonoid.toList_mul, FreeMonoid.toList_of, List.mem_append,
+      List.mem_singleton, Prod.mk.injEq] at hentry
+    rcases hentry with hentry | ⟨heq, _⟩
+    · exact h.1 cell answer hentry
+    · exact False.elim (houtside (heq ▸ cell.property))
+  · intro cell hfresh
+    apply h.2 cell
+    intro answer hentry
+    apply hfresh answer
+    exact List.mem_append_left _ hentry
+
+theorem TraceConsistent.disclose {parameter : PublicParameter}
+    {initial allowed : canonicalEncodingInputs parameter → Finset HashOutput} {trace : OtsContactTrace.Trace}
+    (h : TraceConsistent parameter initial trace allowed) (cell : canonicalEncodingInputs parameter)
+    (output : HashOutput) (houtput : output ∈ allowed cell) :
+    TraceConsistent parameter initial (trace * FreeMonoid.of (cell.val, output))
+      (discloseTableValue allowed cell output) := by
+  constructor
+  · intro other answer hentry
+    simp only [FreeMonoid.toList_mul, FreeMonoid.toList_of, List.mem_append,
+      List.mem_singleton, Prod.mk.injEq] at hentry
+    rcases hentry with hentry | ⟨heq, rfl⟩
+    · by_cases heq : other = cell
+      · subst other
+        have heq : output = answer := Finset.mem_singleton.mp ((h.1 cell answer hentry) ▸ houtput)
+        simp only [discloseTableValue, Function.update_self, heq]
+      · rw [discloseTableValue, Function.update_of_ne heq]
+        exact h.1 other answer hentry
+    · have heq : other = cell := Subtype.ext heq
+      subst other
+      exact Function.update_self cell {answer} allowed
+  · intro other hfresh
+    have heq : other ≠ cell := by
+      intro heq
+      subst other
+      exact hfresh output (List.mem_append_right _ (by simp))
+    rw [discloseTableValue, Function.update_of_ne heq]
+    apply h.2 other
+    intro answer hentry
+    exact hfresh answer (List.mem_append_left _ hentry)
+
+noncomputable def lazyWorldImpl (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (outside : NonencodingRows parameter inputs hencoding) :
+    QueryImpl OracleWorld (StateT (canonicalEncodingInputs parameter → Finset HashOutput) SPMF) :=
+  (UniformTableObservation.lazyImpl (auxiliary parameter inputs hencoding outside)).compose (translate parameter)
+
+theorem lazyRun_eq_simulate {Result : Type} (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (outside : NonencodingRows parameter inputs hencoding)
+    (computation : OracleComp OracleWorld Result) (allowed : canonicalEncodingInputs parameter → Finset HashOutput) :
+    lazyRun parameter inputs hencoding outside computation allowed =
+      (simulateQ (lazyWorldImpl parameter inputs hencoding outside) computation).run allowed := by
+  rw [lazyRun, UniformTableObservation.lazyRun, lazyWorldImpl, QueryImpl.simulateQ_compose]
+
+theorem lazyRun_map {Result Next : Type} (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (outside : NonencodingRows parameter inputs hencoding)
+    (computation : OracleComp OracleWorld Result) (f : Result → Next)
+    (allowed : canonicalEncodingInputs parameter → Finset HashOutput) :
+    lazyRun parameter inputs hencoding outside (f <$> computation) allowed =
+      (fun result => (f result.1, result.2)) <$> lazyRun parameter inputs hencoding outside computation allowed := by
+  simp only [lazyRun_eq_simulate, simulateQ_map, StateT.run_map]
+
+theorem lazyWorldImpl_traceConsistent (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (outside : NonencodingRows parameter inputs hencoding)
+    (initial allowed : canonicalEncodingInputs parameter → Finset HashOutput) (trace : OtsContactTrace.Trace)
+    (h : TraceConsistent parameter initial trace allowed) (input : OracleWorld.Domain)
+    (result : OracleWorld.Range input × (canonicalEncodingInputs parameter → Finset HashOutput))
+    (hr : (lazyWorldImpl parameter inputs hencoding outside input).run allowed result ≠ 0) :
+    TraceConsistent parameter initial (trace * hashObservationTrace input result.1) result.2 := by
+  cases input with
+  | inl input =>
+      simp only [lazyWorldImpl, QueryImpl.compose, translate, simulateQ_spec_query,
+        UniformTableObservation.lazyImpl, StateT.run_mk, ← bind_pure_comp] at hr
+      obtain ⟨answer, _, heq⟩ := (bind_nonzero _ _ _).mp hr
+      simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at heq
+      subst result
+      simpa only [hashObservationTrace, mul_one] using h
+  | inr input =>
+      by_cases hc : input ∈ canonicalEncodingInputs parameter
+      · simp only [lazyWorldImpl, QueryImpl.compose, translate, dif_pos hc, simulateQ_spec_query,
+          UniformTableObservation.lazyImpl, StateT.run_mk, ← bind_pure_comp] at hr
+        obtain ⟨answer, ha, heq⟩ := (bind_nonzero _ _ _).mp hr
+        simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at heq
+        subst result
+        have hin : answer ∈ allowed ⟨input, hc⟩ := by
+          by_contra hn
+          simp only [cell_apply, if_neg hn, ne_eq, not_true_eq_false] at ha
+        exact h.disclose ⟨input, hc⟩ answer hin
+      · simp only [lazyWorldImpl, QueryImpl.compose, translate, dif_neg hc, simulateQ_spec_query,
+          UniformTableObservation.lazyImpl, StateT.run_mk, ← bind_pure_comp] at hr
+        obtain ⟨answer, _, heq⟩ := (bind_nonzero _ _ _).mp hr
+        simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at heq
+        subst result
+        exact h.outside input hc answer
+
+theorem TraceConsistent.cached_reply {parameter : PublicParameter}
+    {initial allowed : canonicalEncodingInputs parameter → Finset HashOutput} {trace : OtsContactTrace.Trace}
+    (h : TraceConsistent parameter initial trace allowed) (cell : canonicalEncodingInputs parameter)
+    (previous output : HashOutput) (hp : (cell.val, previous) ∈ trace.toList)
+    (ho : UniformTableCompletion.cell (allowed cell) output ≠ 0) : output = previous := by
+  rw [h.1 cell previous hp, cell_apply] at ho
+  by_contra hn
+  simp only [Finset.mem_singleton, hn, if_false, ne_eq, not_true_eq_false] at ho
+
+theorem TraceConsistent.new_reply_probability_le {parameter : PublicParameter}
+    {initial allowed : canonicalEncodingInputs parameter → Finset HashOutput} {trace : OtsContactTrace.Trace}
+    (h : TraceConsistent parameter initial trace allowed) (cell : canonicalEncodingInputs parameter)
+    (event : HashOutput → Prop) :
+    Pr[fun output => event output ∧ (cell.val, output) ∉ trace.toList | UniformTableCompletion.cell (allowed cell)] ≤
+      Pr[event | UniformTableCompletion.cell (initial cell)] := by
+  by_cases hfresh : ∀ output, (cell.val, output) ∉ trace.toList
+  · rw [h.2 cell hfresh]
+    exact _root_.probEvent_mono (fun _ _ he => he.1)
+  · obtain ⟨previous, hp⟩ := not_forall.mp hfresh
+    have hp : (cell.val, previous) ∈ trace.toList := not_not.mp hp
+    have hz : Pr[fun output => event output ∧ (cell.val, output) ∉ trace.toList |
+        UniformTableCompletion.cell (allowed cell)] = 0 := by
+      apply probEvent_eq_zero
+      intro output ho he
+      have heq := h.cached_reply cell previous output hp ((SPMF.mem_support_iff _ _).mp ho)
+      exact he.2 (heq.symm ▸ hp)
+    rw [hz]
+    exact bot_le
+
+end SphincsSecurity.Concrete.EncodingObservation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/ExtractChain.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/ExtractChain.lean
new file mode 100644
index 000000000..1dd3058fb
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/ExtractChain.lean
@@ -0,0 +1,75 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.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/Ots/ExtractOts.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/ExtractOts.lean
new file mode 100644
index 000000000..fdb29b43d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/ExtractOts.lean
@@ -0,0 +1,110 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Scheme.Code
+import SphincsSecurity.Proof.Ots.ExtractChain
+import SphincsSecurity.Proof.Ots.OneTime
+/-!
+# 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)
+
+theorem leafOfNat_val : leafOfNat leaf.val = leaf := by
+  ext
+  simp [leafOfNat, Nat.mod_eq_of_lt leaf.isLt]
+
+/-- 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/Ots/LayerCompare.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/LayerCompare.lean
new file mode 100644
index 000000000..107062923
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/LayerCompare.lean
@@ -0,0 +1,32 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Scheme.SignSupport
+/-!
+# 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
+
+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)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/LayerVerifierWitness.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/LayerVerifierWitness.lean
new file mode 100644
index 000000000..8bb8d5017
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/LayerVerifierWitness.lean
@@ -0,0 +1,57 @@
+import SphincsSecurity.Proof.Ots.OtsVerifierWitness
+import SphincsSecurity.Proof.Hypertree.TreeFoldBound
+namespace SphincsSecurity.Concrete.OtsVerifierWitness
+
+open _root_.OracleComp OracleSpec OtsContactTrace
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] chainWalk canonicalPayloadInputs
+
+variable (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (words : OtsReferenceWords)
+  (lay : Layer) (tree : TreeIndex) (secret : LeafIndex → ChainIndex → Digest)
+
+def TreeOutputMatch (trace : Trace) : Prop :=
+  ∃ (level nodeIdx : Nat) (payload : HashInput), payload ∈ canonicalPayloadInputs ∧ level < layerHeight lay ∧ nodeIdx < 2 ^ maxLayerHeight ∧
+    2 ^ (level + 1) * (nodeIdx + 1) ≤ 2 ^ maxLayerHeight ∧
+    (tweakableHashInput parameter (.node lay tree (level + 1) nodeIdx) payload,
+      f (tweakableHashInput parameter (.node lay tree (level + 1) nodeIdx) payload)) ∈ trace.toList ∧
+    NodeHit f parameter lay tree secret level nodeIdx payload
+
+theorem canonicalLeaf_eq_honestNode (leaf : LeafIndex) :
+    canonicalLeaf f parameter lay tree leaf (secret leaf) = honestNode f parameter lay tree secret 0 leaf.val := by
+  rw [honestNode_zero_eq_leafHash]
+  simp only [canonicalLeaf, leafHash, eval_tweakableHash]
+  rfl
+
+theorem layer_classification (leaf : LeafIndex) (hleafIndex : leaf.val < 2 ^ layerHeight lay)
+    (path : Nat → Digest) (message : Digest) (counter : Counter) (values : ChainIndex → Digest)
+    (candidate : Encoding) (leafValue : Digest) (trace : Trace) (hvalid : TargetSum.Valid (words lay tree leaf))
+    (hencode : evalWithAnswerFn f (encode parameter lay tree leaf message counter) = some candidate)
+    (hots : evalWithAnswerFn f (otsLeaf parameter lay tree leaf message counter values) = some leafValue)
+    (hfold : foldValue f parameter lay tree leaf path leafValue (layerHeight lay) =
+      honestNode f parameter lay tree secret (layerHeight lay) 0)
+    (hotsRun : ContainsRun f trace (otsLeaf parameter lay tree leaf message counter values))
+    (hfoldRun : ContainsRun f trace (treeFold parameter lay tree leaf path (layerHeight lay) leafValue)) :
+    (candidate = words lay tree leaf ∧
+      (∀ index, values index = frontier f parameter words lay tree leaf (secret leaf) index) ∧
+      ∀ level, level < layerHeight lay → path level = honestNode f parameter lay tree secret level (Nat.xor (leaf.val / 2 ^ level) 1)) ∨
+      TreeOutputMatch f parameter lay tree secret trace ∨ LeafOutputMatch f parameter lay tree leaf (secret leaf) trace ∨
+        ChainException f parameter words lay tree leaf (secret leaf) trace := by
+  have hroot : foldValue f parameter lay tree leaf path leafValue (layerHeight lay) =
+      honestNode f parameter lay tree secret (layerHeight lay) (leaf.val / 2 ^ layerHeight lay) := by
+    simpa only [Nat.div_eq_of_lt hleafIndex] using hfold
+  rcases treeFold_extract f parameter lay tree secret leaf path leafValue (layerHeight lay) hroot with ⟨hleaf, hpath⟩ | ⟨level, hl, hh⟩
+  · have hcanonical : evalWithAnswerFn f (otsLeaf parameter lay tree leaf message counter values) =
+        some (canonicalLeaf f parameter lay tree leaf (secret leaf)) := by
+      rw [canonicalLeaf_eq_honestNode, hots, hleaf]
+    rcases otsLeaf_classification f parameter words lay tree leaf (secret leaf) message counter values candidate trace hvalid hencode hotsRun hcanonical
+      with ⟨hword, hvalues⟩ | hleafMatch | hchains
+    · exact Or.inl ⟨hword, hvalues, hpath⟩
+    · exact Or.inr (Or.inr (Or.inl hleafMatch))
+    · exact Or.inr (Or.inr (Or.inr hchains))
+  · refine Or.inr (Or.inl ⟨level, leaf.val / 2 ^ (level + 1), _, orderedPayload_mem_canonicalPayloadInputs _ _ _, hl, ?_, ?_, ?_, hh⟩)
+    · exact (Nat.div_le_self _ _).trans_lt leaf.isLt
+    · exact fold_node_bound maxLayerHeight level leaf.val (hl.trans_le (layerHeight_le lay)) leaf.isLt
+    · exact hfoldRun _ (treeFold_query_mem f parameter lay tree leaf path leafValue (layerHeight lay) level hl)
+
+end SphincsSecurity.Concrete.OtsVerifierWitness
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OneTime.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OneTime.lean
new file mode 100644
index 000000000..212ed7a31
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OneTime.lean
@@ -0,0 +1,55 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Ots.Chain
+import SphincsSecurity.Proof.Scheme.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]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsChainBackward.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsChainBackward.lean
new file mode 100644
index 000000000..a9b1fd26d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsChainBackward.lean
@@ -0,0 +1,157 @@
+import SphincsSecurity.Proof.Ots.OtsTwoEdgeTrace
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+
+variable (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex)
+  (leaf : LeafIndex) (chainIdx : ChainIndex) (secret : Digest)
+
+theorem chainWalk_extract_above (start : Nat) (value : Digest) (steps cutoff : Nat)
+    (hrange : start + steps ≤ chainLength - 1) (hcutoff : cutoff ≤ steps)
+    (hwalk : walkValue f parameter lay tree leaf chainIdx start value steps
+      = honestChain f parameter lay tree leaf chainIdx secret (start + steps)) :
+    walkValue f parameter lay tree leaf chainIdx start value cutoff
+        = honestChain f parameter lay tree leaf chainIdx secret (start + cutoff)
+      ∨ ∃ (offset : Nat) (hoffset : start + offset < chainLength - 1),
+          cutoff ≤ offset ∧ 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 =>
+      have : cutoff = 0 := by omega
+      subst cutoff
+      exact Or.inl hwalk
+  | succ steps ih =>
+      by_cases heq : cutoff = steps + 1
+      · subst cutoff
+        exact Or.inl hwalk
+      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) (by omega) hagree with hvalue | ⟨offset, hoffset, hcut, ho, hhit⟩
+        · exact Or.inl hvalue
+        · exact Or.inr ⟨offset, hoffset, hcut, by omega, hhit⟩
+      · refine Or.inr ⟨steps, hlt, by omega, 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
+
+namespace SphincsSecurity.Concrete.OtsContactTrace
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] chainWalk
+
+def ContainsRun {Result : Type} (f : QueryImpl HashSpec Id) (trace : Trace)
+    (computation : OracleComp HashSpec Result) : Prop :=
+  ∀ input ∈ queriedInputs f computation, (input, f input) ∈ trace.toList
+
+theorem ContainsRun.bind_left {Result Next : Type} {f : QueryImpl HashSpec Id} {trace : Trace}
+    {computation : OracleComp HashSpec Result} {next : Result → OracleComp HashSpec Next}
+    (h : ContainsRun f trace (computation >>= next)) : ContainsRun f trace computation :=
+  fun _ hi => h _ (queriedInputs_mono_bind_left f computation next hi)
+
+theorem ContainsRun.bind_right {Result Next : Type} {f : QueryImpl HashSpec Id} {trace : Trace}
+    {computation : OracleComp HashSpec Result} {next : Result → OracleComp HashSpec Next}
+    (h : ContainsRun f trace (computation >>= next)) : ContainsRun f trace (next (evalWithAnswerFn f computation)) :=
+  fun _ hi => h _ (queriedInputs_mono_bind_right f computation next hi)
+
+theorem ContainsRun.sequenceFin_component {Result : Type} {n : Nat} {f : QueryImpl HashSpec Id} {trace : Trace}
+    (computation : Fin n → OracleComp HashSpec Result) (h : ContainsRun f trace (sequenceFin computation)) (index : Fin n) :
+    ContainsRun f trace (computation index) :=
+  fun _ hi => h _ (sequenceFin_component_query_mem f computation index hi)
+
+def ForwardChainMatch (f : QueryImpl HashSpec Id) (segment : OtsPrefix) (secret : Digest) (trace : Trace) : Prop :=
+  ∃ (step : ChainStep) (payload : Digest), segment.digit.val ≤ step.val ∧
+    (tweakableHashInput segment.parameter (.chain segment.lay segment.tree segment.leaf segment.chainIdx step) (digestBytes payload),
+      f (tweakableHashInput segment.parameter (.chain segment.lay segment.tree segment.leaf segment.chainIdx step) (digestBytes payload)))
+        ∈ trace.toList ∧
+    ChainHit f segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx secret step.val step.isLt payload
+
+variable (f : QueryImpl HashSpec Id) (segment : OtsPrefix) (secret value : Digest) (digit : Digit) (trace : Trace)
+
+theorem recover_canonical_above (cutoff : Nat) (hcut : cutoff ≤ chainLength - 1 - digit.val)
+    (habove : segment.digit.val ≤ digit.val + cutoff)
+    (hendpoint : evalWithAnswerFn f (recoverChain segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx digit value)
+      = honestChain f segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx secret (chainLength - 1))
+    (hrun : ContainsRun f trace (recoverChain segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx digit value))
+    (hforward : ¬ForwardChainMatch f segment secret trace) :
+    walkValue f segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx digit.val value cutoff
+      = honestChain f segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx secret (digit.val + cutoff) := by
+  have hd : digit.val ≤ chainLength - 1 := Nat.le_pred_of_lt digit.isLt
+  have hwalk : walkValue f segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx digit.val value
+      (chainLength - 1 - digit.val) = honestChain f segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx secret
+        (digit.val + (chainLength - 1 - digit.val)) := by
+    simpa only [walkValue, recoverChain, Nat.add_sub_of_le hd] using hendpoint
+  rcases chainWalk_extract_above f segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx secret digit.val value
+      (chainLength - 1 - digit.val) cutoff (by omega) hcut hwalk with h | ⟨offset, ho, hc, hs, hh⟩
+  · exact h
+  · exact False.elim (hforward ⟨⟨digit.val + offset, ho⟩, _, by dsimp; omega,
+      hrun _ (chainWalk_query_mem f segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx digit.val
+        (chainLength - 1 - digit.val) value offset hs ho), hh⟩)
+
+theorem recover_frontier (hbelow : digit.val ≤ segment.digit.val)
+    (hendpoint : evalWithAnswerFn f (recoverChain segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx digit value)
+      = honestChain f segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx secret (chainLength - 1))
+    (hrun : ContainsRun f trace (recoverChain segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx digit value))
+    (hforward : ¬ForwardChainMatch f segment secret trace) :
+    walkValue f segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx digit.val value (segment.digit.val - digit.val)
+      = honestChain f segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx secret segment.digit.val := by
+  have hd : segment.digit.val ≤ chainLength - 1 := Nat.le_pred_of_lt segment.digit.isLt
+  simpa only [Nat.add_sub_of_le hbelow] using
+    recover_canonical_above f segment secret value digit trace (segment.digit.val - digit.val) (by omega) (by omega) hendpoint hrun hforward
+
+theorem recover_value (habove : segment.digit.val ≤ digit.val)
+    (hendpoint : evalWithAnswerFn f (recoverChain segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx digit value)
+      = honestChain f segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx secret (chainLength - 1))
+    (hrun : ContainsRun f trace (recoverChain segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx digit value))
+    (hforward : ¬ForwardChainMatch f segment secret trace) :
+    value = honestChain f segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx secret digit.val := by
+  simpa only [walkValue, chainWalk, evalWithAnswerFn_pure, Nat.add_zero] using
+    recover_canonical_above f segment secret value digit trace 0 (by omega) (by omega) hendpoint hrun hforward
+
+theorem recover_row (offset : Nat) (hprefix : digit.val + offset < segment.digit.val)
+    (hrun : ContainsRun f trace (recoverChain segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx digit value)) :
+    SeenRow segment ⟨⟨digit.val + offset, hprefix⟩,
+      walkValue f segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx digit.val value offset⟩
+      (walkValue f segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx digit.val value (offset + 1)) trace := by
+  have hd : segment.digit.val ≤ chainLength - 1 := Nat.le_pred_of_lt segment.digit.isLt
+  have ho : digit.val + offset < chainLength - 1 := by omega
+  refine ⟨_, hrun _ (chainWalk_query_mem f segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx digit.val
+    (chainLength - 1 - digit.val) value offset (by omega) ho), ?_, ?_⟩
+  · exact segment.parse_input ⟨⟨digit.val + offset, hprefix⟩,
+      walkValue f segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx digit.val value offset⟩
+  · exact (walkValue_succ f segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx digit.val value offset ho).symm
+
+theorem recover_contact (hbelow : digit.val < segment.digit.val) (endpoint : Digest)
+    (hfrontier : walkValue f segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx digit.val value
+      (segment.digit.val - digit.val) = endpoint)
+    (hrun : ContainsRun f trace (recoverChain segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx digit value)) :
+    Seen segment endpoint trace := by
+  have ho : digit.val + (segment.digit.val - digit.val - 1) < segment.digit.val := by omega
+  have hr := recover_row f segment value digit trace (segment.digit.val - digit.val - 1) ho hrun
+  rw [show segment.digit.val - digit.val - 1 + 1 = segment.digit.val - digit.val by omega, hfrontier] at hr
+  obtain ⟨entry, he, hp, hv⟩ := hr
+  exact ⟨entry, he, _, hp, by dsimp; omega, hv⟩
+
+theorem recover_twoEdge (hbelow : digit.val + 2 ≤ segment.digit.val) (endpoint : Digest)
+    (hfrontier : walkValue f segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx digit.val value
+      (segment.digit.val - digit.val) = endpoint)
+    (hrun : ContainsRun f trace (recoverChain segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx digit value)) :
+    SeenTwoEdge segment endpoint trace := by
+  have hf : digit.val + (segment.digit.val - digit.val - 2) < segment.digit.val := by omega
+  have hl : digit.val + (segment.digit.val - digit.val - 1) < segment.digit.val := by omega
+  refine ⟨⟨⟨_, hf⟩, walkValue f segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx digit.val value
+    (segment.digit.val - digit.val - 2)⟩,
+    ⟨⟨_, hl⟩, walkValue f segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx digit.val value
+      (segment.digit.val - digit.val - 1)⟩, ?_, ?_, ?_, ?_⟩
+  · dsimp; omega
+  · dsimp; omega
+  · simpa only [show segment.digit.val - digit.val - 2 + 1 = segment.digit.val - digit.val - 1 by omega] using
+      recover_row f segment value digit trace (segment.digit.val - digit.val - 2) hf hrun
+  · have hr := recover_row f segment value digit trace (segment.digit.val - digit.val - 1) hl hrun
+    rw [show segment.digit.val - digit.val - 1 + 1 = segment.digit.val - digit.val by omega, hfrontier] at hr
+    simpa only [show segment.digit.val - digit.val - 2 + 1 = segment.digit.val - digit.val - 1 by omega] using hr
+
+end SphincsSecurity.Concrete.OtsContactTrace
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactAllocation.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactAllocation.lean
new file mode 100644
index 000000000..ddd6f3117
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactAllocation.lean
@@ -0,0 +1,75 @@
+import SphincsSecurity.Proof.Ots.OtsContactPause
+import SphincsSecurity.Proof.Base.QueryPauseTrace
+namespace SphincsSecurity.Concrete.OtsContactTrace
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] contacts
+
+noncomputable def prefixCalls (segment : OtsPrefix) (trace : Trace) : Nat :=
+  QueryCap.calls segment.Selects (trace.toList.map fun entry => (.inr entry.1 : OracleWorld.Domain))
+
+theorem prefixCalls_one (segment : OtsPrefix) : prefixCalls segment 1 = 0 := rfl
+
+theorem prefixCalls_mul (segment : OtsPrefix) (first second : Trace) :
+    prefixCalls segment (first * second) = prefixCalls segment first + prefixCalls segment second := by
+  simp only [prefixCalls, FreeMonoid.toList_mul, List.map_append, QueryCap.calls, List.countP_append]
+
+theorem prefixCalls_step (segment : OtsPrefix) (input : OracleWorld.Domain) (answer : OracleWorld.Range input) (trace : Trace) :
+    prefixCalls segment (hashObservationTrace input answer * trace) = (if segment.Selects input then 1 else 0) + prefixCalls segment trace := by
+  cases input with
+  | inl input => simp only [hashObservationTrace, one_mul, OtsPrefix.Selects, if_false, Nat.zero_add]
+  | inr bytes =>
+      simp only [prefixCalls, hashObservationTrace, FreeMonoid.toList_mul, FreeMonoid.toList_of, List.singleton_append,
+        List.map_cons, QueryCap.calls_cons]
+
+theorem traced_hash_counted {Result : Type} (computation : OracleComp OracleWorld Result) :
+    (fun result => (result.1, result.2.toList.length)) <$> QueryPause.traced hashObservationTrace computation =
+      QueryCap.counted CausalFrontierProgram.IsHash computation := by
+  apply QueryPause.traced_counted hashObservationTrace CausalFrontierProgram.IsHash (fun trace => trace.toList.length) rfl
+  intro input answer trace
+  cases input <;> simp only [hashObservationTrace, one_mul, CausalFrontierProgram.IsHash, reduceCtorEq, ↓reduceIte,
+    Nat.zero_add, FreeMonoid.toList_mul, FreeMonoid.toList_of, List.length_append, List.length_singleton]
+
+private theorem hash_calls_map (entries : List (HashInput × HashOutput)) :
+    QueryCap.calls CausalFrontierProgram.IsHash (entries.map fun entry => (.inr entry.1 : OracleWorld.Domain)) = entries.length := by
+  induction entries with
+  | nil => rfl
+  | cons entry entries ih =>
+      simp only [List.map_cons, QueryCap.calls_cons, CausalFrontierProgram.IsHash, ↓reduceIte, ih, List.length_cons, Nat.add_comm]
+
+theorem prefixCalls_allocation (parameter : PublicParameter) (words : OtsReferenceWords)
+    (addresses : Finset OtsPrefix.ChainAddress) (trace : Trace) :
+    (∑ address ∈ addresses, prefixCalls (OtsPrefix.atAddress parameter words address) trace) ≤ trace.toList.length := by
+  simpa only [prefixCalls, hash_calls_map] using
+    OtsPrefix.allocation_le parameter words addresses (trace.toList.map fun entry => (.inr entry.1 : OracleWorld.Domain))
+
+theorem restartCharge_allocation (parameter : PublicParameter) (words : OtsReferenceWords)
+    (addresses : Finset OtsPrefix.ChainAddress) (before after : Trace) :
+    (∑ address ∈ addresses, (prefixCalls (OtsPrefix.atAddress parameter words address) before +
+      2 * prefixCalls (OtsPrefix.atAddress parameter words address) after)) ≤ before.toList.length + 2 * after.toList.length := by
+  rw [Finset.sum_add_distrib, ← Finset.mul_sum]
+  exact Nat.add_le_add (prefixCalls_allocation parameter words addresses before)
+    (Nat.mul_le_mul_left 2 (prefixCalls_allocation parameter words addresses after))
+
+theorem restartCharge_le_budget (parameter : PublicParameter) (words : OtsReferenceWords)
+    (addresses : Finset OtsPrefix.ChainAddress) (before after : Trace) (budget : Nat)
+    (hbudget : (before * after).toList.length ≤ budget) :
+    (∑ address ∈ addresses, (prefixCalls (OtsPrefix.atAddress parameter words address) before +
+      2 * prefixCalls (OtsPrefix.atAddress parameter words address) after)) ≤ 2 * budget := by
+  apply (restartCharge_allocation parameter words addresses before after).trans
+  simp only [FreeMonoid.toList_mul, List.length_append] at hbudget
+  omega
+
+theorem traced_game_cost (parameter : PublicParameter) (external : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (adversary : Adversary) (result : (Bool × SigningBoundaryTrace) × Trace)
+    (hresult : result ∈ support (QueryPause.traced hashObservationTrace
+      (CausalFrontierProgram.game parameter external ftsSecret words frontier adversary))) : result.2.toList.length ≤ result.1.2.hashCalls := by
+  apply CausalFrontierProgram.game_counted_le parameter external ftsSecret words frontier adversary
+    (result.1, result.2.toList.length)
+  rw [← traced_hash_counted, support_map]
+  exact ⟨result, hresult, rfl⟩
+
+end SphincsSecurity.Concrete.OtsContactTrace
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactCheckpoint.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactCheckpoint.lean
new file mode 100644
index 000000000..45c9d52f3
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactCheckpoint.lean
@@ -0,0 +1,53 @@
+import SphincsSecurity.Proof.Ots.OtsPrefixVisibleContact
+import SphincsSecurity.Proof.Ots.OtsContactSplit
+import SphincsSecurity.Proof.Chains.AdaptiveChainPotential
+namespace SphincsSecurity.Concrete.OtsPrefix
+
+open _root_.OracleComp OracleSpec PartialChainEndpoint
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+
+variable (segment : OtsPrefix) (high : segment.Query → High) (auxiliary : QueryImpl OracleWorld PMF)
+  (stop : OtsContactTrace.Trace → Prop) [DecidablePred stop]
+  {Result : Type} (computation : OracleComp OracleWorld Result) (trace : OtsContactTrace.Trace)
+  (observed : Fin segment.digit.val → Digest → Option Digest)
+
+theorem lazyRun_visible_pause :
+    lazyRun auxiliary (QueryPause.run stop
+      (fun input answer history => history * segment.visibleObservationTrace high input answer)
+      (simulateQ (segment.visibleWorldImpl high) computation) trace) observed =
+    ((simulateQ (segment.visibleLazyImpl high auxiliary)
+      (QueryPause.run stop (fun input answer history => history * hashObservationTrace input answer) computation trace)).run observed).map
+        (fun result => ((result.1.1, simulateQ (segment.visibleWorldImpl high) result.1.2), result.2)) := by
+  rw [visible_pause_program, lazyRun_map]
+  simp only [lazyRun, visibleLazyImpl, QueryImpl.simulateQ_compose]
+
+theorem lazyRun_visible_pause_observation (endpoint : Digest)
+    (hseen : OtsContactTrace.Seen segment endpoint trace ↔ Contact observed endpoint)
+    (hcount : queryCount observed ≤ OtsContactTrace.prefixCalls segment trace)
+    (result : (OtsContactTrace.Trace × OracleComp segment.VisibleWorld Result) × (Fin segment.digit.val → Digest → Option Digest))
+    (hresult : result ∈ (lazyRun auxiliary (QueryPause.run stop
+      (fun input answer history => history * segment.visibleObservationTrace high input answer)
+      (simulateQ (segment.visibleWorldImpl high) computation) trace) observed).support) :
+    (OtsContactTrace.Seen segment endpoint result.1.1 ↔ Contact result.2 endpoint) ∧
+      queryCount result.2 ≤ OtsContactTrace.prefixCalls segment result.1.1 := by
+  rw [lazyRun_visible_pause, PMF.mem_support_map_iff] at hresult
+  obtain ⟨source, hsource, rfl⟩ := hresult
+  exact ⟨segment.visible_pause_contact high auxiliary endpoint stop computation trace observed hseen source hsource,
+    segment.visible_pause_queryCount high auxiliary stop computation trace observed hcount source hsource⟩
+
+end SphincsSecurity.Concrete.OtsPrefix
+
+namespace SphincsSecurity.Concrete.OtsContactTrace
+
+open _root_.OracleComp OracleSpec PartialChainEndpoint
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] contacts
+
+variable (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+  (address : OtsPrefix.ChainAddress)
+  (high : (OtsPrefix.atAddress parameter words address).Query → OtsPrefix.High) (auxiliary : QueryImpl OracleWorld PMF)
+  {Result : Type} (computation : OracleComp OracleWorld Result)
+
+end SphincsSecurity.Concrete.OtsContactTrace
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactEvents.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactEvents.lean
new file mode 100644
index 000000000..a06ddd13b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactEvents.lean
@@ -0,0 +1,94 @@
+import SphincsSecurity.Proof.Ots.OtsContactRestart
+import SphincsSecurity.Proof.Ots.OtsContactSourceAllocation
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec PartialChainEndpoint
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] OtsContactTrace.contacts canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+def ContactResult.NewContact (parameter : PublicParameter) (words : OtsReferenceWords)
+    (address : OtsPrefix.ChainAddress) (result : ContactResult) : Prop :=
+  (result.Marked parameter words ∧ address ∉ OtsContactTrace.contacts parameter words result.frontier result.before) ∧
+    address ∈ OtsContactTrace.contacts parameter words result.frontier (result.before * result.after)
+
+theorem ContactResult.newContact_eq_seen (parameter : PublicParameter) (words : OtsReferenceWords)
+    (address : OtsPrefix.ChainAddress) (result : ContactResult) (endpoint : Digest)
+    (hendpoint : result.frontier address.1 address.2.1 address.2.2.1 address.2.2.2 = endpoint) :
+    result.NewContact parameter words address ↔
+      (result.Marked parameter words ∧ ¬OtsContactTrace.Seen (OtsPrefix.atAddress parameter words address) endpoint result.before) ∧
+      OtsContactTrace.Seen (OtsPrefix.atAddress parameter words address) endpoint (result.before * result.after) := by
+  simp only [NewContact, OtsContactTrace.mem_contacts, hendpoint]
+
+theorem OtsPrefix.instrumentedContact_endpoint (segment : OtsPrefix) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs) (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+    (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph) (secrets : OtsFrontierValues)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (adversary : Adversary)
+    (result : Digest × ContactResult × (Fin segment.digit.val → Digest → Option Digest))
+    (hresult : result ∈ (realRun (fun _ => OtsPrefix.uniformImpl)
+      (fun endpoint => segment.instrumentedSeedGame contactObserver inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+      (fun _ _ => none)).support) : result.2.1.frontier segment.lay segment.tree segment.leaf segment.chainIdx = result.1 := by
+  rw [← segment.contactCheckpointRun_project inputs hencoding hgraph auxiliary secrets ftsSecret words adversary,
+    PMF.mem_support_map_iff] at hresult
+  obtain ⟨checkpoint, _, rfl⟩ := hresult
+  simp only [OtsPrefix.seedFrontier, OtsPrefix.frontierFromEndpoint, OtsPrefix.replaceChain, OtsPrefix.SameChain,
+    and_self, if_true]
+
+variable (parameter : PublicParameter) (words : OtsReferenceWords) (address : OtsPrefix.ChainAddress)
+  (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (hgraph : canonicalGraphInputs parameter ⊆ inputs)
+  (auxiliary : (OtsPrefix.atAddress parameter words address).ReferenceAuxSeed inputs hencoding hgraph) (secrets : OtsFrontierValues)
+  (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (adversary : Adversary)
+
+theorem contactSeed_newContact_le (budget : Nat)
+    (hreal : ∀ result ∈ (realRun (fun _ => OtsPrefix.uniformImpl)
+      (fun endpoint => (OtsPrefix.atAddress parameter words address).seedGame inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+      (fun _ _ => none)).support, result.2.1.2.hashCalls ≤ budget)
+    (hsmall : budget < Fintype.card Digest) :
+    let segment := OtsPrefix.atAddress parameter words address
+    let law := realRun (fun _ => OtsPrefix.uniformImpl)
+      (fun endpoint => segment.instrumentedSeedGame contactObserver inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+      (fun _ _ => none)
+    (1 - (budget : ENNReal) / Fintype.card Digest) * ((Fintype.card Digest : ENNReal) *
+      Pr[fun result => result.2.1.NewContact parameter words address | law]) ≤
+      ∑' result, law result * (result.2.1.restartCharge parameter words address : ENNReal) := by
+  dsimp only
+  let segment := OtsPrefix.atAddress parameter words address
+  let law := realRun (fun _ => OtsPrefix.uniformImpl)
+    (fun endpoint => segment.instrumentedSeedGame contactObserver inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+    (fun _ _ => none)
+  have hevent : Pr[fun result => result.2.1.NewContact parameter words address | law] =
+      Pr[fun result => (result.2.1.Marked parameter words ∧ ¬OtsContactTrace.Seen segment result.1 result.2.1.before) ∧
+        OtsContactTrace.Seen segment result.1 (result.2.1.before * result.2.1.after) | law] := by
+    simp only [probEvent_eq_tsum_ite, PMF.probOutput_eq_apply]
+    apply tsum_congr
+    intro result
+    by_cases hr : result ∈ law.support
+    · rw [ContactResult.newContact_eq_seen parameter words address result.2.1 result.1
+        (segment.instrumentedContact_endpoint inputs hencoding hgraph auxiliary secrets ftsSecret words adversary result hr)]
+      simp only [segment]
+    · have hz : law result = 0 := not_not.mp hr
+      simp only [hz, ite_self]
+  have hcost : (∑' result, law result * (result.2.1.restartCharge parameter words address : ENNReal)) =
+      ∑' result, law result *
+        (((OtsContactTrace.prefixCalls segment result.2.1.before + 2 * OtsContactTrace.prefixCalls segment result.2.1.after : Nat) : ENNReal) *
+          if result.2.1.Marked parameter words ∧ ¬OtsContactTrace.Seen segment result.1 result.2.1.before then 1 else 0) := by
+    apply tsum_congr
+    intro result
+    by_cases hr : result ∈ law.support
+    · have he := segment.instrumentedContact_endpoint inputs hencoding hgraph auxiliary secrets ftsSecret words adversary result hr
+      change result.2.1.frontier address.1 address.2.1 address.2.2.1 address.2.2.2 = result.1 at he
+      simp only [ContactResult.restartCharge, OtsContactTrace.mem_contacts, he]
+      by_cases hm : result.2.1.Marked parameter words ∧ ¬OtsContactTrace.Seen segment result.1 result.2.1.before
+      · simp only [segment] at hm ⊢
+        simp only [if_pos hm, mul_one]
+      · simp only [segment] at hm ⊢
+        simp only [if_neg hm, Nat.cast_zero, mul_zero]
+    · have hz : law result = 0 := not_not.mp hr
+      simp only [hz, zero_mul]
+  change (1 - (budget : ENNReal) / Fintype.card Digest) * ((Fintype.card Digest : ENNReal) *
+    Pr[fun result => result.2.1.NewContact parameter words address | law]) ≤ _
+  rw [hevent]
+  rw [show (∑' result, law result * (result.2.1.restartCharge parameter words address : ENNReal)) = _ from hcost]
+  exact segment.instrumentedSeed_newContact_le inputs hencoding hgraph auxiliary secrets ftsSecret words adversary budget hreal hsmall
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactFirstLaw.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactFirstLaw.lean
new file mode 100644
index 000000000..785a66c25
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactFirstLaw.lean
@@ -0,0 +1,87 @@
+import SphincsSecurity.Proof.Ots.OtsContactEvents
+import SphincsSecurity.Proof.Ots.OtsPrefixContactProbability
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec PartialChainEndpoint
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition OtsContactTrace.contacts
+
+def ContactResult.Contacted (parameter : PublicParameter) (words : OtsReferenceWords)
+    (address : OtsPrefix.ChainAddress) (result : ContactResult) : Prop :=
+  address ∈ OtsContactTrace.contacts parameter words result.frontier (result.before * result.after)
+
+namespace OtsPrefix
+
+variable (segment : OtsPrefix) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs) (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+  (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph) (secrets : OtsFrontierValues)
+  (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (adversary : Adversary)
+
+theorem instrumentedContact_seen (result : Digest × ContactResult × (Fin segment.digit.val → Digest → Option Digest))
+    (hresult : result ∈ (realRun (fun _ => uniformImpl)
+      (fun endpoint => segment.instrumentedSeedGame contactObserver inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+      (fun _ _ => none)).support) :
+    OtsContactTrace.Seen segment result.1 (result.2.1.before * result.2.1.after) ↔ Contact result.2.2 result.1 := by
+  rw [← segment.contactCheckpointRun_project inputs hencoding hgraph auxiliary secrets ftsSecret words adversary,
+    PMF.mem_support_map_iff] at hresult
+  obtain ⟨checkpoint, hcheckpoint, rfl⟩ := hresult
+  exact (segment.traceCheckpointRun_observation OtsContactTrace.Stopped inputs hencoding hgraph auxiliary secrets ftsSecret words adversary checkpoint hcheckpoint).2.1
+
+theorem instrumentedContact_forget (endpoint : Digest) :
+    ContactResult.output <$> segment.instrumentedSeedGame contactObserver inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary =
+      segment.seedGame inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary := by
+  rw [instrumentedSeedGame, ← simulateQ_map, contactObserver_forget]
+  rw [CausalFrontierProgram.prefix_game]
+  rfl
+
+theorem instrumentedContact_real_forget :
+    (realRun (fun _ => uniformImpl)
+      (fun endpoint => segment.instrumentedSeedGame contactObserver inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+      (fun _ _ => none)).map (fun result => (result.1, result.2.1.output, result.2.2)) =
+    realRun (fun _ => uniformImpl)
+      (fun endpoint => segment.seedGame inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary) (fun _ _ => none) := by
+  simpa only [segment.instrumentedContact_forget inputs hencoding hgraph auxiliary secrets ftsSecret words adversary] using
+    (realRun_map (fun _ => uniformImpl)
+      (fun endpoint => segment.instrumentedSeedGame contactObserver inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+      (fun _ => ContactResult.output) (fun _ _ => none)).symm
+
+end OtsPrefix
+
+theorem contactSeed_contacted_eq (parameter : PublicParameter) (words : OtsReferenceWords) (address : OtsPrefix.ChainAddress)
+    (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (hgraph : canonicalGraphInputs parameter ⊆ inputs)
+    (auxiliary : (OtsPrefix.atAddress parameter words address).ReferenceAuxSeed inputs hencoding hgraph) (secrets : OtsFrontierValues)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (adversary : Adversary) :
+    let segment := OtsPrefix.atAddress parameter words address
+    (realRun (fun _ => OtsPrefix.uniformImpl)
+      (fun endpoint => segment.instrumentedSeedGame contactObserver inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+      (fun _ _ => none)).map (fun result => decide (result.2.1.Contacted parameter words address)) =
+    (realRun (fun _ => OtsPrefix.uniformImpl)
+      (fun endpoint => segment.seedGame inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+      (fun _ _ => none)).map (fun result => decide (Contact result.2.2 result.1)) := by
+  dsimp only
+  let segment := OtsPrefix.atAddress parameter words address
+  rw [← segment.instrumentedContact_real_forget inputs hencoding hgraph auxiliary secrets ftsSecret words adversary,
+    PMF.map_comp]
+  apply PMF.ext
+  intro value
+  simp only [PMF.map_apply]
+  apply tsum_congr
+  intro result
+  by_cases hr : result ∈ (realRun (fun _ => OtsPrefix.uniformImpl)
+      (fun endpoint => segment.instrumentedSeedGame contactObserver inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+      (fun _ _ => none)).support
+  swap
+  · have hz := not_not.mp hr
+    simp only [segment] at hz ⊢
+    simp only [hz, ite_self]
+  have he := segment.instrumentedContact_endpoint inputs hencoding hgraph auxiliary secrets ftsSecret words adversary result hr
+  have hc := segment.instrumentedContact_seen inputs hencoding hgraph auxiliary secrets ftsSecret words adversary result hr
+  change result.2.1.frontier address.1 address.2.1 address.2.2.1 address.2.2.2 = result.1 at he
+  simp only [ContactResult.Contacted, OtsContactTrace.mem_contacts, he, Function.comp_def]
+  rw [hc]
+  by_cases hv : value = decide (Contact result.2.2 result.1)
+  · simp only [if_pos hv, segment]
+  · simp only [if_neg hv]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactFirstProbability.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactFirstProbability.lean
new file mode 100644
index 000000000..5e541466f
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactFirstProbability.lean
@@ -0,0 +1,116 @@
+import SphincsSecurity.Proof.Ots.OtsContactFirstLaw
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition OtsContactTrace.contacts Finset.univ
+
+theorem referenceContactGame_contacted_law (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (fun result => decide (result.2.2.Contacted result.1 (referenceFamilyWords result.2.1 dummy) address)) <$>
+      referenceContactGame inputs hencoding dummy adversary = prefixContactGame inputs hencoding hgraph address dummy adversary := by
+  rw [← prefixContactObservedGame_original inputs hencoding hgraph address dummy adversary]
+  unfold prefixContactObservedGame prefixInstrumentedObservedGame prefixContactGame
+  simp only [map_bind, map_pure]
+  apply congrArg (𝒟[sampleParameter] >>= ·)
+  funext parameter
+  apply congrArg (𝒟[sampleFtsSecrets] >>= ·)
+  funext ftsSecret
+  apply congrArg (𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit] >>= ·)
+  funext selections
+  let words := referenceFamilyWords selections dummy
+  let segment := OtsPrefix.atAddress parameter words address
+  apply congrArg (𝒟[PMF.uniformOfFintype segment.ErasedSecrets] >>= ·)
+  funext other
+  apply congrArg (𝒟[segment.referenceAuxSeedLaw inputs (hencoding parameter) (hgraph parameter) selections] >>= ·)
+  funext auxiliary
+  have h := congrArg (fun law : PMF Bool => 𝒟[law])
+    (contactSeed_contacted_eq parameter words address inputs (hencoding parameter) (hgraph parameter) auxiliary other.val ftsSecret adversary)
+  simpa only [← PMF.monad_map_eq_map, evalDist_map, bind_map_left, bind_pure_comp, Functor.map_map, Function.comp_def] using h
+
+theorem referenceContactGame_contacted_eq (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    Pr[fun result => result.2.2.Contacted result.1 (referenceFamilyWords result.2.1 dummy) address |
+      referenceContactGame inputs hencoding dummy adversary] =
+    Pr[= true | prefixContactGame inputs hencoding hgraph address dummy adversary] := by
+  rw [← referenceContactGame_contacted_law inputs hencoding hgraph address dummy adversary, ← probEvent_eq_eq_probOutput, probEvent_map]
+  simp only [Function.comp_def, decide_eq_true_eq]
+
+theorem referenceContactGame_marked_le_sum (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    Pr[fun result => result.2.2.Marked result.1 (referenceFamilyWords result.2.1 dummy) |
+      referenceContactGame inputs hencoding dummy adversary] ≤
+    ∑ address : OtsPrefix.ChainAddress, Pr[= true | prefixContactGame inputs hencoding hgraph address dummy adversary] := by
+  simp only [← referenceContactGame_contacted_eq inputs hencoding hgraph]
+  let law := referenceContactGame inputs hencoding dummy adversary
+  let event := fun address : OtsPrefix.ChainAddress => fun result : InstrumentedResult ContactResult =>
+    result.2.2.Contacted result.1 (referenceFamilyWords result.2.1 dummy) address
+  refine (_root_.probEvent_mono (mx := law) (q := fun result => ∃ address ∈ (Finset.univ : Finset OtsPrefix.ChainAddress), event address result) ?_).trans
+    (probEvent_exists_finset_le_sum Finset.univ law event)
+  intro result _ hm
+  obtain ⟨address, ha⟩ := hm
+  refine ⟨address, Finset.mem_univ address, ?_⟩
+  change address ∈ OtsContactTrace.contacts result.1 (referenceFamilyWords result.2.1 dummy) result.2.2.frontier (result.2.2.before * result.2.2.after)
+  rw [OtsContactTrace.contacts_mul]
+  exact Finset.mem_union_left _ ha
+
+theorem referenceContactGame_sum_contact_probability (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (∑ address : OtsPrefix.ChainAddress, Pr[= true | prefixContactGame inputs hencoding hgraph address dummy adversary]) =
+      ∑' result, Pr[= result | referenceContactGame inputs hencoding dummy adversary] *
+        ((OtsContactTrace.contacts result.1 (referenceFamilyWords result.2.1 dummy) result.2.2.frontier
+          (result.2.2.before * result.2.2.after)).card : ENNReal) := by
+  simp only [← referenceContactGame_contacted_eq inputs hencoding hgraph, ContactResult.Contacted]
+  rw [← tsum_fintype (L := SummationFilter.unconditional OtsPrefix.ChainAddress)]
+  simp only [probEvent_eq_tsum_ite]
+  rw [ENNReal.tsum_comm]
+  apply tsum_congr
+  intro result
+  rw [tsum_fintype, Fintype.sum_ite_mem, Finset.sum_const, nsmul_eq_mul, mul_comm]
+
+theorem referenceContactGame_contacts_cost_le (dummy : OtsReferenceWords) (adversary : Adversary) (q : Nat)
+    (hbound : HasHashQueryBound scheme adversary q) (hsmall : q < Fintype.card Digest) :
+    (1 - (q : ENNReal) / Fintype.card Digest) *
+      (∑' result, Pr[= result | referenceContactGame (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] *
+          ((OtsContactTrace.contacts result.1 (referenceFamilyWords result.2.1 dummy) result.2.2.frontier
+            (result.2.2.before * result.2.2.after)).card : ENNReal)) ≤
+      (2 / Fintype.card Digest) *
+        (∑' result : ReferenceRecordedResult, Pr[= result | referenceRecordedGame (canonicalGraphGameInputs adversary)
+          (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] * (result.prefixCalls dummy : ENNReal)) := by
+  rw [← referenceContactGame_sum_contact_probability _ _ (canonicalGraphInputs_subset_gameInputs adversary)]
+  have hsum := Finset.sum_le_sum (s := (Finset.univ : Finset OtsPrefix.ChainAddress))
+    fun address _ => prefixContactGame_le address dummy adversary q hbound hsmall
+  rw [← Finset.mul_sum] at hsum
+  have hlower := Finset.sum_le_sum (s := (Finset.univ : Finset OtsPrefix.ChainAddress))
+    fun address _ => prefixIdealCostGame_lower address dummy adversary q hbound
+  rw [← Finset.mul_sum] at hlower
+  simp only [prefixCountedObservedGame_original, tsum_probOutput_map_mul, ReferenceRecordedResult.prefixCounted] at hlower
+  conv at hlower =>
+    rhs
+    rw [← tsum_fintype (L := SummationFilter.unconditional OtsPrefix.ChainAddress), ENNReal.tsum_comm]
+    simp only [tsum_fintype, ← Finset.mul_sum, ← Nat.cast_sum]
+  have hscaled := mul_le_mul' (le_refl (1 - (q : ENNReal) / Fintype.card Digest)) hsum
+  rw [mul_left_comm] at hscaled
+  exact hscaled.trans (mul_le_mul' le_rfl hlower)
+
+theorem referenceContactGame_marked_cost_le (dummy : OtsReferenceWords) (adversary : Adversary) (q : Nat)
+    (hbound : HasHashQueryBound scheme adversary q) (hsmall : q < Fintype.card Digest) :
+    (1 - (q : ENNReal) / Fintype.card Digest) *
+      Pr[fun result => result.2.2.Marked result.1 (referenceFamilyWords result.2.1 dummy) |
+        referenceContactGame (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] ≤
+      (2 / Fintype.card Digest) *
+        (∑' result : ReferenceRecordedResult, Pr[= result | referenceRecordedGame (canonicalGraphGameInputs adversary)
+          (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] * (result.prefixCalls dummy : ENNReal)) := by
+  have h := mul_le_mul' (le_refl (1 - (q : ENNReal) / Fintype.card Digest))
+    (referenceContactGame_marked_le_sum _ (canonicalEncodingInputs_subset_gameInputs adversary)
+      (canonicalGraphInputs_subset_gameInputs adversary) dummy adversary)
+  rw [referenceContactGame_sum_contact_probability] at h
+  exact h.trans (referenceContactGame_contacts_cost_le dummy adversary q hbound hsmall)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactMarkerBound.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactMarkerBound.lean
new file mode 100644
index 000000000..74b038ee5
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactMarkerBound.lean
@@ -0,0 +1,90 @@
+import SphincsSecurity.Proof.Ots.EncodingContactMarkerSource
+import SphincsSecurity.Proof.Ots.OtsContactFirstProbability
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec OtsEncodingMarker
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphInputs canonicalEncodingInputs canonicalGraphGameInputs Finset.univ OtsContactTrace.contacts
+
+theorem referenceContactGame_contactMarker_le_cost (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    Pr[fun result => ContactBeforeMarker result.1 (referenceFamilyWords result.2.1 dummy) result.2.2.frontier
+      (result.2.2.before * result.2.2.after) | referenceContactGame inputs hencoding dummy adversary] ≤
+      (41 / (Fintype.card Digest : ENNReal)) * ∑' result,
+        Pr[= result | referenceContactGame inputs hencoding dummy adversary] *
+          (contactMarkerCost result.1 (referenceFamilyWords result.2.1 dummy) result.2.2.frontier 1 (result.2.2.before * result.2.2.after) : ENNReal) := by
+  refine le_trans ?_ (referenceContactGame_contactMarker_count_le inputs hencoding hgraph dummy adversary)
+  rw [probEvent_eq_tsum_ite]
+  apply ENNReal.tsum_le_tsum
+  intro result
+  split
+  · rename_i he
+    have hp := (contactMarkerCount_pos_iff _ _ _ _).mpr he
+    exact (mul_one _).symm.trans_le (mul_le_mul' le_rfl (by exact_mod_cast Nat.succ_le_iff.mpr hp))
+  · exact bot_le
+
+theorem referenceContactGame_contactMarker_le_contacts (dummy : OtsReferenceWords) (adversary : Adversary) (budget : Nat)
+    (hbound : HasHashQueryBound scheme adversary budget) :
+    Pr[fun result => ContactBeforeMarker result.1 (referenceFamilyWords result.2.1 dummy) result.2.2.frontier
+      (result.2.2.before * result.2.2.after) | referenceContactGame (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] ≤
+      (41 * ((budget : ENNReal) / Fintype.card Digest)) * ∑' result,
+        Pr[= result | referenceContactGame (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] *
+          ((OtsContactTrace.contacts result.1 (referenceFamilyWords result.2.1 dummy) result.2.2.frontier
+            (result.2.2.before * result.2.2.after)).card : ENNReal) := by
+  have hcost : (∑' result, Pr[= result | referenceContactGame (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] *
+        (contactMarkerCost result.1 (referenceFamilyWords result.2.1 dummy) result.2.2.frontier 1 (result.2.2.before * result.2.2.after) : ENNReal)) ≤
+      (budget : ENNReal) * ∑' result, Pr[= result | referenceContactGame (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] *
+          ((OtsContactTrace.contacts result.1 (referenceFamilyWords result.2.1 dummy) result.2.2.frontier
+            (result.2.2.before * result.2.2.after)).card : ENNReal) := by
+    rw [← ENNReal.tsum_mul_left]
+    apply ENNReal.tsum_le_tsum
+    intro result
+    by_cases hr : result ∈ support (referenceContactGame (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary)
+    · have hl := (referenceContactGame_cost _ _ dummy adversary result hr).trans
+        (referenceContactGame_hashCalls_le dummy adversary budget hbound result hr)
+      have hc := (contactMarkerCost_le result.1 (referenceFamilyWords result.2.1 dummy) result.2.2.frontier 1
+        (result.2.2.before * result.2.2.after)).trans (Nat.mul_le_mul_right _ hl)
+      simp only [one_mul] at hc
+      rw [mul_left_comm (budget : ENNReal)]
+      apply mul_le_mul' le_rfl
+      exact_mod_cast hc
+    · rw [probOutput_eq_zero_of_not_mem_support hr, zero_mul, zero_mul, mul_zero]
+  refine (referenceContactGame_contactMarker_le_cost _ _ (canonicalGraphInputs_subset_gameInputs adversary) dummy adversary).trans
+    ((mul_le_mul' le_rfl hcost).trans_eq ?_)
+  simp only [div_eq_mul_inv]
+  ring
+
+theorem referenceContactGame_contactMarker_shared_bound (dummy : OtsReferenceWords) (adversary : Adversary) (budget : Nat)
+    (hbound : HasHashQueryBound scheme adversary budget) (hsmall : budget < Fintype.card Digest) :
+    ((1 - (budget : ENNReal) / Fintype.card Digest) * (Fintype.card Digest : ENNReal)) *
+      Pr[fun result => ContactBeforeMarker result.1 (referenceFamilyWords result.2.1 dummy) result.2.2.frontier
+        (result.2.2.before * result.2.2.after) | referenceContactGame (canonicalGraphGameInputs adversary)
+          (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] ≤
+      (82 * ((budget : ENNReal) / Fintype.card Digest)) * ∑' result,
+        Pr[= result | referenceRecordedGame (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] *
+          (result.prefixCalls dummy : ENNReal) := by
+  have hraw := mul_le_mul' (le_refl (1 - (budget : ENNReal) / Fintype.card Digest))
+    (referenceContactGame_contactMarker_le_contacts dummy adversary budget hbound)
+  rw [mul_left_comm] at hraw
+  have hc := hraw.trans (mul_le_mul' le_rfl (referenceContactGame_contacts_cost_le dummy adversary budget hbound hsmall))
+  have hn : (Fintype.card Digest : ENNReal) ≠ 0 := by exact_mod_cast Fintype.card_ne_zero
+  have h := mul_le_mul' (le_refl (Fintype.card Digest : ENNReal)) hc
+  have hcancel : (Fintype.card Digest : ENNReal) * (Fintype.card Digest : ENNReal)⁻¹ = 1 := ENNReal.mul_inv_cancel hn (by finiteness)
+  rw [mul_left_comm (Fintype.card Digest : ENNReal), ← mul_assoc] at h
+  refine h.trans_eq ?_
+  simp only [div_eq_mul_inv]
+  calc
+    _ = 82 * ((budget : ENNReal) * (Fintype.card Digest : ENNReal)⁻¹) *
+        (∑' result, Pr[= result | referenceRecordedGame (canonicalGraphGameInputs adversary)
+          (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] * (result.prefixCalls dummy : ENNReal)) *
+        ((Fintype.card Digest : ENNReal) * (Fintype.card Digest : ENNReal)⁻¹) := by ring
+    _ = _ := by rw [hcancel, mul_one]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactMarkerTrace.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactMarkerTrace.lean
new file mode 100644
index 000000000..ac915f0f3
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactMarkerTrace.lean
@@ -0,0 +1,81 @@
+import SphincsSecurity.Proof.Ots.EncodingAdaptiveMarker
+import SphincsSecurity.Proof.Base.TraceSum
+namespace SphincsSecurity.Concrete.OtsEncodingMarker
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+local instance (priority := 11000) : DecidableEq OtsPrefix.ChainAddress := inferInstance
+attribute [local instance 10000] Classical.propDecidable
+attribute [local irreducible] OtsContactTrace.contacts canonicalEncodingInputs Finset.univ
+
+def ContactBeforeEntry (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (history : OtsContactTrace.Trace) (entry : HashInput × HashOutput) : Prop :=
+  ∃ address ∈ OtsContactTrace.contacts parameter words frontier history, NewMarker parameter words history address entry
+
+noncomputable def contactMarkerCount (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (trace : OtsContactTrace.Trace) : Nat :=
+  TraceSum.run (fun history entry => if ContactBeforeEntry parameter words frontier history entry then 1 else 0) 1 trace.toList
+
+def ContactBeforeMarker (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (trace : OtsContactTrace.Trace) : Prop :=
+  ∃ before entry after, trace.toList = before ++ entry :: after ∧
+    ContactBeforeEntry parameter words frontier (FreeMonoid.ofList before) entry
+
+theorem contactMarkerCount_pos_iff (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (trace : OtsContactTrace.Trace) :
+    0 < contactMarkerCount parameter words frontier trace ↔ ContactBeforeMarker parameter words frontier trace := by
+  rw [contactMarkerCount, TraceSum.run_pos_iff]
+  have hi : ∀ p : Prop, (0 < (if p then 1 else 0 : Nat)) ↔ p := by
+    intro p
+    by_cases hp : p <;> simp [hp]
+  simp only [one_mul, hi, ContactBeforeMarker]
+
+theorem contactMarkerCount_one (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues) :
+    contactMarkerCount parameter words frontier 1 = 0 := rfl
+
+theorem contactMarkerCount_step (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (history : OtsContactTrace.Trace) (entry : HashInput × HashOutput) :
+    contactMarkerCount parameter words frontier (history * FreeMonoid.of entry) =
+      contactMarkerCount parameter words frontier history + if ContactBeforeEntry parameter words frontier history entry then 1 else 0 := by
+  simp only [contactMarkerCount, FreeMonoid.toList_mul, FreeMonoid.toList_of, TraceSum.run_append,
+    TraceSum.run_cons, TraceSum.run_nil, FreeMonoid.ofList_toList, one_mul, Nat.add_zero]
+
+noncomputable def contactMarkerCharge (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (history : OtsContactTrace.Trace) (input : OracleWorld.Domain) : Nat :=
+  if QueryClass.EncodingHash parameter input then (OtsContactTrace.contacts parameter words frontier history).card else 0
+
+noncomputable def contactMarkerCost (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (history tail : OtsContactTrace.Trace) : Nat :=
+  TraceSum.run (fun history entry => contactMarkerCharge parameter words frontier history (.inr entry.1)) history tail.toList
+
+theorem contactMarkerCost_one (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (history : OtsContactTrace.Trace) : contactMarkerCost parameter words frontier history 1 = 0 := rfl
+
+theorem contactMarkerCost_step (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (history : OtsContactTrace.Trace) (input : OracleWorld.Domain) (answer : OracleWorld.Range input) (tail : OtsContactTrace.Trace) :
+    contactMarkerCost parameter words frontier history (hashObservationTrace input answer * tail) =
+      contactMarkerCharge parameter words frontier history input +
+        contactMarkerCost parameter words frontier (history * hashObservationTrace input answer) tail := by
+  cases input with
+  | inl input =>
+      simp only [hashObservationTrace, one_mul, mul_one, contactMarkerCharge, QueryClass.EncodingHash, if_false, Nat.zero_add]
+  | inr input => rfl
+
+theorem contactMarkerCost_le (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (history tail : OtsContactTrace.Trace) :
+    contactMarkerCost parameter words frontier history tail ≤
+      tail.toList.length * (OtsContactTrace.contacts parameter words frontier (history * tail)).card := by
+  apply TraceSum.run_le_length_mul
+  intro before entry after he
+  have ht : tail = FreeMonoid.ofList before * FreeMonoid.ofList (entry :: after) := by
+    simpa only [FreeMonoid.ofList_toList, FreeMonoid.ofList_append] using congrArg FreeMonoid.ofList he
+  have hsub : OtsContactTrace.contacts parameter words frontier (history * FreeMonoid.ofList before) ⊆
+      OtsContactTrace.contacts parameter words frontier (history * tail) := by
+    rw [ht, ← mul_assoc, OtsContactTrace.contacts_mul parameter words frontier (history * FreeMonoid.ofList before)]
+    exact Finset.subset_union_left
+  dsimp only [contactMarkerCharge]
+  split
+  · exact Finset.card_le_card hsub
+  · exact Nat.zero_le _
+
+end SphincsSecurity.Concrete.OtsEncodingMarker
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactPause.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactPause.lean
new file mode 100644
index 000000000..d5298fcad
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactPause.lean
@@ -0,0 +1,41 @@
+import SphincsSecurity.Proof.Ots.OtsContactTrace
+import SphincsSecurity.Proof.Base.QueryPauseInvariant
+namespace SphincsSecurity.Concrete.OtsContactTrace
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] contacts
+
+variable (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+
+def Stopped (trace : Trace) : Prop := (contacts parameter words frontier trace).Nonempty
+
+noncomputable def pause {Result : Type} (computation : OracleComp OracleWorld Result) :=
+  QueryPause.run (Stopped parameter words frontier)
+    (fun input answer history => history * hashObservationTrace input answer) computation 1
+
+theorem pause_card_le_one {Result : Type} (computation : OracleComp OracleWorld Result)
+    (result : Trace × OracleComp OracleWorld Result) (hresult : result ∈ support (pause parameter words frontier computation)) :
+    (contacts parameter words frontier result.1).card ≤ 1 := by
+  apply QueryPause.run_invariant (Stopped parameter words frontier) _
+    (fun trace => (contacts parameter words frontier trace).card ≤ 1) _ computation 1 _ result hresult
+  · intro trace _ hstop input answer
+    have hempty : contacts parameter words frontier trace = ∅ := Finset.not_nonempty_iff_eq_empty.mp hstop
+    have h := contacts_step_card_le parameter words frontier trace input answer
+    simpa only [hempty, Finset.card_empty, Nat.zero_add] using h
+  · simp only [contacts_one, Finset.card_empty, Nat.zero_le]
+
+theorem pause_stopped_or_finished {Result : Type} (computation : OracleComp OracleWorld Result)
+    (result : Trace × OracleComp OracleWorld Result) (hresult : result ∈ support (pause parameter words frontier computation)) :
+    Stopped parameter words frontier result.1 ∨ ∃ value, result.2 = pure value :=
+  QueryPause.run_stopped_or_finished (Stopped parameter words frontier) _ computation 1 result hresult
+
+theorem pause_new_contact {Result : Type} (computation : OracleComp OracleWorld Result)
+    (result : Trace × OracleComp OracleWorld Result) (hresult : result ∈ support (pause parameter words frontier computation))
+    (after : Trace) (htwo : 2 ≤ (contacts parameter words frontier (result.1 * after)).card) :
+    ∃ address, address ∉ contacts parameter words frontier result.1 ∧ address ∈ contacts parameter words frontier after :=
+  new_contact_of_two parameter words frontier result.1 after
+    (pause_card_le_one parameter words frontier computation result hresult) htwo
+
+end SphincsSecurity.Concrete.OtsContactTrace
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactProbability.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactProbability.lean
new file mode 100644
index 000000000..163db9caa
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactProbability.lean
@@ -0,0 +1,61 @@
+import SphincsSecurity.Proof.Ots.OtsContactEvents
+import SphincsSecurity.Proof.Ots.OtsPrefixObservedBudget
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+private theorem probComp_mem_of_evalDist {Result : Type} (computation : ProbComp Result) (result : Result)
+    (hresult : result ∈ support 𝒟[computation]) : result ∈ support computation :=
+  (mem_support_iff_of_evalDist_eq (mx := computation) (mx' := 𝒟[computation]) rfl result).mpr hresult
+
+private theorem pmf_mem_of_evalDist {Result : Type} (law : PMF Result) (result : Result)
+    (hresult : result ∈ support 𝒟[law]) : result ∈ law.support := by
+  change result ∈ (𝒟[law]).support at hresult
+  simpa only [PMF.evalDist_eq, SPMF.support_liftM] using hresult
+
+theorem referenceContactGame_newContact_le (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords)
+    (adversary : Adversary) (budget : Nat) (hbound : HasHashQueryBound scheme adversary budget) (hsmall : budget < Fintype.card Digest) :
+    let law := referenceContactGame (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary
+    ((1 - (budget : ENNReal) / Fintype.card Digest) * (Fintype.card Digest : ENNReal)) *
+      Pr[fun result => result.2.2.NewContact result.1 (referenceFamilyWords result.2.1 dummy) address | law] ≤
+      ∑' result, Pr[= result | law] * (result.2.2.restartCharge result.1 (referenceFamilyWords result.2.1 dummy) address : ENNReal) := by
+  dsimp only
+  have h : ((1 - (budget : ENNReal) / Fintype.card Digest) * (Fintype.card Digest : ENNReal)) *
+      (∑' result : InstrumentedResult ContactResult, Pr[= result | prefixContactObservedGame (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary) (canonicalGraphInputs_subset_gameInputs adversary) address dummy adversary] *
+        (if result.2.2.NewContact result.1 (referenceFamilyWords result.2.1 dummy) address then 1 else 0)) ≤
+      ∑' result : InstrumentedResult ContactResult, Pr[= result | prefixContactObservedGame (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary) (canonicalGraphInputs_subset_gameInputs adversary) address dummy adversary] *
+        (result.2.2.restartCharge result.1 (referenceFamilyWords result.2.1 dummy) address : ENNReal) := by
+    unfold prefixContactObservedGame prefixInstrumentedObservedGame
+    apply QueryCap.scaled_expectation_bind_le
+    intro parameter hparameter
+    apply QueryCap.scaled_expectation_bind_le
+    intro ftsSecret _
+    apply QueryCap.scaled_expectation_bind_le
+    intro selections hselections
+    apply QueryCap.scaled_expectation_bind_le
+    intro other _
+    apply QueryCap.scaled_expectation_bind_le
+    intro auxiliary hauxiliary
+    let words := referenceFamilyWords selections dummy
+    let segment := OtsPrefix.atAddress parameter words address
+    let inputs := canonicalGraphGameInputs adversary
+    let hencoding := canonicalEncodingInputs_subset_gameInputs adversary parameter
+    let hgraph := canonicalGraphInputs_subset_gameInputs adversary parameter
+    have hreal : ∀ result ∈ (PartialChainEndpoint.realRun (fun _ => OtsPrefix.uniformImpl)
+        (fun endpoint => segment.seedGame inputs hencoding hgraph auxiliary other.val ftsSecret words endpoint adversary) (fun _ _ => none)).support,
+        result.2.1.2.hashCalls ≤ budget :=
+      prefixObservedRun_hashCalls_le parameter (probComp_mem_of_evalDist _ parameter hparameter) ftsSecret
+        address.1 address.2.1 address.2.2.1 address.2.2.2 dummy adversary selections (pmf_mem_of_evalDist _ selections hselections)
+        budget hbound other auxiliary (pmf_mem_of_evalDist _ auxiliary hauxiliary)
+    have hseed := contactSeed_newContact_le parameter words address inputs hencoding hgraph auxiliary other.val ftsSecret adversary budget hreal hsmall
+    simp only [← PMF.monad_map_eq_map, evalDist_map, tsum_probOutput_bind_mul, tsum_probOutput_map_mul, tsum_probOutput_pure_mul]
+    simpa only [PMF.evalDist_eq, SPMF.probOutput_liftM, PMF.probOutput_eq_apply,
+      probEvent_eq_tsum_ite, mul_ite, mul_one, mul_zero, mul_assoc] using hseed
+  simpa only [prefixContactObservedGame_original, probEvent_eq_tsum_ite, mul_ite, mul_one, mul_zero] using h
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactRestart.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactRestart.lean
new file mode 100644
index 000000000..505d792ef
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactRestart.lean
@@ -0,0 +1,63 @@
+import SphincsSecurity.Proof.Ots.OtsTraceRestart
+
+/-! ## OtsContactCheckpointLaw -/
+
+namespace SphincsSecurity.Concrete.OtsPrefix
+
+open _root_.OracleComp OracleSpec PartialChainEndpoint
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+variable (segment : OtsPrefix) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs) (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+  (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph) (secrets : OtsFrontierValues)
+  (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (adversary : Adversary)
+
+noncomputable abbrev contactCheckpointRun :=
+  segment.traceCheckpointRun OtsContactTrace.Stopped inputs hencoding hgraph auxiliary secrets ftsSecret words adversary
+
+theorem contactCheckpointRun_project :
+    (segment.contactCheckpointRun inputs hencoding hgraph auxiliary secrets ftsSecret words adversary).map
+      (fun result => (result.1,
+        (⟨segment.seedFrontier inputs hencoding hgraph auxiliary secrets words result.1,
+          result.2.1.1.1.1, result.2.2.1.1.1, result.2.2.1.1.2⟩ : ContactResult), result.2.2.2)) =
+    realRun (fun _ => uniformImpl)
+      (fun endpoint => segment.instrumentedSeedGame contactObserver inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+      (fun _ _ => none) := by
+  simpa only [checkpointObserver_contact] using
+    segment.traceCheckpointRun_project OtsContactTrace.Stopped inputs hencoding hgraph auxiliary secrets ftsSecret words adversary
+
+end SphincsSecurity.Concrete.OtsPrefix
+
+namespace SphincsSecurity.Concrete.OtsPrefix
+
+open _root_.OracleComp OracleSpec PartialChainEndpoint
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+variable (segment : OtsPrefix) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs) (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+  (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph) (secrets : OtsFrontierValues)
+  (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (adversary : Adversary)
+
+theorem instrumentedSeed_newContact_le (budget : Nat)
+    (hreal : ∀ result ∈ (realRun (fun _ => uniformImpl)
+      (fun endpoint => segment.seedGame inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary) (fun _ _ => none)).support,
+      result.2.1.2.hashCalls ≤ budget)
+    (hsmall : budget < Fintype.card Digest) :
+    let law := realRun (fun _ => uniformImpl)
+      (fun endpoint => segment.instrumentedSeedGame contactObserver inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+      (fun _ _ => none)
+    (1 - (budget : ENNReal) / Fintype.card Digest) * ((Fintype.card Digest : ENNReal) *
+      Pr[fun result => (result.2.1.Marked segment.parameter words ∧ ¬OtsContactTrace.Seen segment result.1 result.2.1.before) ∧
+        OtsContactTrace.Seen segment result.1 (result.2.1.before * result.2.1.after) | law]) ≤
+    ∑' result, law result *
+      (((OtsContactTrace.prefixCalls segment result.2.1.before + 2 * OtsContactTrace.prefixCalls segment result.2.1.after : Nat) : ENNReal) *
+        if result.2.1.Marked segment.parameter words ∧ ¬OtsContactTrace.Seen segment result.1 result.2.1.before then 1 else 0) := by
+  simpa only [ContactResult.Marked, checkpointObserver_contact] using
+    segment.instrumentedCheckpoint_newContact_le OtsContactTrace.Stopped inputs hencoding hgraph auxiliary secrets ftsSecret words adversary
+      budget hreal hsmall
+
+end SphincsSecurity.Concrete.OtsPrefix
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactSourceAllocation.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactSourceAllocation.lean
new file mode 100644
index 000000000..2d82a956c
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactSourceAllocation.lean
@@ -0,0 +1,57 @@
+import SphincsSecurity.Proof.Reference.ReferenceContactGame
+import SphincsSecurity.Proof.Ots.OtsPrefixInstrumentedSource
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphInputs canonicalEncodingInputs canonicalGraphGameInputs OtsContactTrace.contacts
+
+noncomputable abbrev prefixContactObservedGame (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords) (adversary : Adversary) :=
+  prefixInstrumentedObservedGame contactObserver inputs hencoding hgraph address dummy adversary
+
+theorem prefixContactObservedGame_original (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    prefixContactObservedGame inputs hencoding hgraph address dummy adversary = referenceContactGame inputs hencoding dummy adversary :=
+  prefixInstrumentedObservedGame_original contactObserver inputs hencoding hgraph address dummy adversary
+
+theorem referenceContactGame_restart_allocation (dummy : OtsReferenceWords) (adversary : Adversary) (budget : Nat)
+    (hbound : HasHashQueryBound scheme adversary budget) :
+    let law := referenceContactGame (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary
+    (∑ address : OtsPrefix.ChainAddress, ∑' result : InstrumentedResult ContactResult,
+      Pr[= result | law] * (result.2.2.restartCharge result.1 (referenceFamilyWords result.2.1 dummy) address : ENNReal)) ≤
+        ((2 * budget : Nat) : ENNReal) * Pr[fun result => result.2.2.Marked result.1 (referenceFamilyWords result.2.1 dummy) | law] := by
+  dsimp only
+  let law := referenceContactGame (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary
+  calc
+    _ = ∑' result : InstrumentedResult ContactResult, Pr[= result | law] *
+        ((∑ address : OtsPrefix.ChainAddress, result.2.2.restartCharge result.1 (referenceFamilyWords result.2.1 dummy) address : Nat) : ENNReal) := by
+      rw [← tsum_fintype (L := SummationFilter.unconditional OtsPrefix.ChainAddress), ENNReal.tsum_comm]
+      simp only [tsum_fintype, Nat.cast_sum, Finset.mul_sum, law]
+    _ ≤ ∑' result : InstrumentedResult ContactResult, Pr[= result | law] *
+        if result.2.2.Marked result.1 (referenceFamilyWords result.2.1 dummy) then ((2 * budget : Nat) : ENNReal) else 0 := by
+      apply ENNReal.tsum_le_tsum
+      intro result
+      by_cases hr : result ∈ support law
+      · apply mul_le_mul' le_rfl
+        have hcost := (referenceContactGame_cost _ _ dummy adversary result hr).trans
+          (referenceContactGame_hashCalls_le dummy adversary budget hbound result hr)
+        have hn := ContactResult.restartCharge_sum_le result.1 (referenceFamilyWords result.2.1 dummy) result.2.2 budget hcost
+        by_cases hm : result.2.2.Marked result.1 (referenceFamilyWords result.2.1 dummy)
+        · rw [if_pos hm] at hn ⊢
+          exact_mod_cast hn
+        · rw [if_neg hm] at hn ⊢
+          exact_mod_cast hn
+      · rw [probOutput_eq_zero_of_not_mem_support hr, zero_mul, zero_mul]
+    _ = _ := by
+      rw [probEvent_eq_tsum_ite, ← ENNReal.tsum_mul_left]
+      apply tsum_congr
+      intro result
+      by_cases hm : result.2.2.Marked result.1 (referenceFamilyWords result.2.1 dummy)
+      · simp only [if_pos hm, mul_comm, law]
+      · simp only [if_neg hm, mul_zero]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactSplit.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactSplit.lean
new file mode 100644
index 000000000..808258722
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactSplit.lean
@@ -0,0 +1,59 @@
+import SphincsSecurity.Proof.Ots.OtsContactAllocation
+namespace SphincsSecurity.Concrete.OtsContactTrace
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] contacts
+
+variable (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+
+noncomputable def splitRun {Result : Type} (computation : OracleComp OracleWorld Result) :
+    OracleComp OracleWorld (Trace × (Result × Trace)) := do
+  let middle ← pause parameter words frontier computation
+  let tail ← QueryPause.traced hashObservationTrace middle.2
+  pure (middle.1, tail)
+
+theorem splitRun_trace {Result : Type} (computation : OracleComp OracleWorld Result) :
+    (fun result => (result.2.1, result.1 * result.2.2)) <$> splitRun parameter words frontier computation =
+      QueryPause.traced hashObservationTrace computation := by
+  have h := QueryPause.trace_resume hashObservationTrace (Stopped parameter words frontier) computation 1
+  have hmap : (fun result : Result × Trace => (result.1, 1 * result.2)) <$>
+      QueryPause.traced hashObservationTrace computation = QueryPause.traced hashObservationTrace computation := by
+    simp only [one_mul]
+    change id <$> _ = _
+    exact id_map _
+  simpa only [splitRun, pause, map_bind, map_pure] using h.trans hmap
+
+theorem splitRun_forget {Result : Type} (computation : OracleComp OracleWorld Result) :
+    (fun result => result.2.1) <$> splitRun parameter words frontier computation = computation := by
+  have h := congrArg (Functor.map Prod.fst) (splitRun_trace parameter words frontier computation)
+  simpa only [Functor.map_map, QueryPause.traced_forget] using h
+
+theorem splitRun_two_contacts {Result : Type} (computation : OracleComp OracleWorld Result)
+    (result : Trace × (Result × Trace)) (hresult : result ∈ support (splitRun parameter words frontier computation))
+    (htwo : 2 ≤ (contacts parameter words frontier (result.1 * result.2.2)).card) :
+    Stopped parameter words frontier result.1 ∧
+      ∃ address, address ∉ contacts parameter words frontier result.1 ∧ address ∈ contacts parameter words frontier result.2.2 := by
+  simp only [splitRun, mem_support_bind_iff, mem_support_pure_iff] at hresult
+  obtain ⟨middle, hmiddle, tail, htail, rfl⟩ := hresult
+  refine ⟨?_, pause_new_contact parameter words frontier computation middle hmiddle tail.2 htwo⟩
+  rcases pause_stopped_or_finished parameter words frontier computation middle hmiddle with hstop | ⟨value, hvalue⟩
+  · exact hstop
+  · rw [hvalue, QueryPause.traced_pure, mem_support_pure_iff] at htail
+    subst tail
+    simp only [mul_one] at htwo
+    have hone := pause_card_le_one parameter words frontier computation middle hmiddle
+    omega
+
+theorem splitRun_game_cost (external : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (adversary : Adversary)
+    (result : Trace × ((Bool × SigningBoundaryTrace) × Trace))
+    (hresult : result ∈ support (splitRun parameter words frontier
+      (CausalFrontierProgram.game parameter external ftsSecret words frontier adversary))) :
+    (result.1 * result.2.2).toList.length ≤ result.2.1.2.hashCalls := by
+  apply traced_game_cost parameter external ftsSecret words frontier adversary (result.2.1, result.1 * result.2.2)
+  rw [← splitRun_trace parameter words frontier, support_map]
+  exact ⟨result, hresult, rfl⟩
+
+end SphincsSecurity.Concrete.OtsContactTrace
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactTrace.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactTrace.lean
new file mode 100644
index 000000000..81f97b6b4
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsContactTrace.lean
@@ -0,0 +1,94 @@
+import SphincsSecurity.Proof.Ots.OtsPrefixVisibleTrace
+import SphincsSecurity.Proof.Ots.OtsPrefixAllocation
+namespace SphincsSecurity.Concrete.OtsContactTrace
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+
+abbrev Trace := FreeMonoid (HashInput × HashOutput)
+
+def EntryContact (segment : OtsPrefix) (endpoint : Digest) (entry : HashInput × HashOutput) : Prop :=
+  ∃ query : segment.Query, segment.parse entry.1 = some query ∧ query.1.val + 1 = segment.digit.val ∧ truncateHash entry.2 = endpoint
+
+def Seen (segment : OtsPrefix) (endpoint : Digest) (trace : Trace) : Prop :=
+  ∃ entry ∈ trace.toList, EntryContact segment endpoint entry
+
+theorem entryContact_selects (segment : OtsPrefix) (endpoint : Digest) (entry : HashInput × HashOutput)
+    (h : EntryContact segment endpoint entry) : segment.Selects (.inr entry.1) := by
+  obtain ⟨query, hquery, _⟩ := h
+  change segment.parse entry.1 ≠ none
+  rw [hquery]
+  exact Option.some_ne_none query
+
+theorem entryContact_unique (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (entry : HashInput × HashOutput) (left right : OtsPrefix.ChainAddress)
+    (hleft : EntryContact (OtsPrefix.atAddress parameter words left) (frontier left.1 left.2.1 left.2.2.1 left.2.2.2) entry)
+    (hright : EntryContact (OtsPrefix.atAddress parameter words right) (frontier right.1 right.2.1 right.2.2.1 right.2.2.2) entry) : left = right :=
+  OtsPrefix.atAddress_selects_unique parameter words left right (.inr entry.1)
+    (entryContact_selects _ _ entry hleft) (entryContact_selects _ _ entry hright)
+
+theorem seen_one (segment : OtsPrefix) (endpoint : Digest) : ¬Seen segment endpoint 1 := by
+  simp [Seen]
+
+theorem seen_of (segment : OtsPrefix) (endpoint : Digest) (entry : HashInput × HashOutput) :
+    Seen segment endpoint (FreeMonoid.of entry) ↔ EntryContact segment endpoint entry := by
+  simp [Seen]
+
+theorem seen_mul (segment : OtsPrefix) (endpoint : Digest) (first second : Trace) :
+    Seen segment endpoint (first * second) ↔ Seen segment endpoint first ∨ Seen segment endpoint second := by
+  simp only [Seen, FreeMonoid.toList_mul, List.mem_append, or_and_right, exists_or]
+
+noncomputable def contacts (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues) (trace : Trace) :
+    Finset OtsPrefix.ChainAddress :=
+  Finset.univ.filter fun address => Seen (OtsPrefix.atAddress parameter words address)
+    (frontier address.1 address.2.1 address.2.2.1 address.2.2.2) trace
+
+theorem mem_contacts (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (trace : Trace) (address : OtsPrefix.ChainAddress) :
+    address ∈ contacts parameter words frontier trace ↔ Seen (OtsPrefix.atAddress parameter words address)
+      (frontier address.1 address.2.1 address.2.2.1 address.2.2.2) trace := by simp only [contacts, Finset.mem_filter, Finset.mem_univ, true_and]
+
+theorem contacts_one (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues) :
+    contacts parameter words frontier 1 = ∅ := by
+  ext address
+  simp only [mem_contacts, seen_one, Finset.notMem_empty]
+
+theorem contacts_mul (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues) (first second : Trace) :
+    contacts parameter words frontier (first * second) = contacts parameter words frontier first ∪ contacts parameter words frontier second := by
+  ext address
+  simp only [mem_contacts, seen_mul, Finset.mem_union]
+
+attribute [local irreducible] contacts
+
+theorem contacts_of_card_le_one (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (entry : HashInput × HashOutput) : (contacts parameter words frontier (FreeMonoid.of entry)).card ≤ 1 := by
+  rw [Finset.card_le_one]
+  intro left hleft right hright
+  rw [mem_contacts, seen_of] at hleft hright
+  exact entryContact_unique parameter words frontier entry left right hleft hright
+
+theorem contacts_step_card_le (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (trace : Trace) (input : OracleWorld.Domain) (answer : OracleWorld.Range input) :
+    (contacts parameter words frontier (trace * hashObservationTrace input answer)).card ≤
+      (contacts parameter words frontier trace).card + 1 := by
+  cases input with
+  | inl input => simp only [hashObservationTrace, mul_one]; omega
+  | inr input =>
+      rw [hashObservationTrace, contacts_mul]
+      exact (Finset.card_union_le _ _).trans (Nat.add_le_add_left (contacts_of_card_le_one parameter words frontier (input, answer)) _)
+
+theorem new_contact_of_two (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (before after : Trace) (hbefore : (contacts parameter words frontier before).card ≤ 1)
+    (hafter : 2 ≤ (contacts parameter words frontier (before * after)).card) :
+    ∃ address, address ∉ contacts parameter words frontier before ∧ address ∈ contacts parameter words frontier after := by
+  by_contra h
+  push Not at h
+  have hsub : contacts parameter words frontier after ⊆ contacts parameter words frontier before := by
+    intro address ha
+    by_contra hb
+    exact h address hb ha
+  rw [contacts_mul, Finset.union_eq_left.mpr hsub] at hafter
+  omega
+
+end SphincsSecurity.Concrete.OtsContactTrace
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsDistinctContactBound.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsDistinctContactBound.lean
new file mode 100644
index 000000000..642cc84d8
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsDistinctContactBound.lean
@@ -0,0 +1,43 @@
+import SphincsSecurity.Proof.Ots.OtsDistinctContactProbability
+import SphincsSecurity.Proof.Ots.OtsContactFirstProbability
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphInputs canonicalEncodingInputs canonicalGraphGameInputs
+
+theorem referenceContactGame_distinct_cost_le (dummy : OtsReferenceWords) (adversary : Adversary) (q : Nat)
+    (hbound : HasHashQueryBound scheme adversary q) (hsmall : q < Fintype.card Digest) :
+    (1 - (q : ENNReal) / Fintype.card Digest)^2 * (Fintype.card Digest : ENNReal) *
+      Pr[fun result => result.2.2.TwoContacts result.1 (referenceFamilyWords result.2.1 dummy) |
+        referenceContactGame (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] ≤
+      (4 * ((q : ENNReal) / Fintype.card Digest)) *
+        (∑' result : ReferenceRecordedResult, Pr[= result | referenceRecordedGame (canonicalGraphGameInputs adversary)
+          (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] * (result.prefixCalls dummy : ENNReal)) := by
+  have hrestart := mul_le_mul' (le_refl (1 - (q : ENNReal) / Fintype.card Digest))
+    (referenceContactGame_distinct_restart_le dummy adversary q hbound hsmall)
+  have hfirst := mul_le_mul' (le_refl (2 * (q : ENNReal)))
+    (referenceContactGame_marked_cost_le dummy adversary q hbound hsmall)
+  simp only [Nat.cast_mul, Nat.cast_ofNat] at hrestart
+  rw [mul_left_comm (1 - (q : ENNReal) / Fintype.card Digest) (2 * (q : ENNReal))] at hrestart
+  have h := hrestart.trans hfirst
+  convert h using 1 <;> first | rfl | (simp only [div_eq_mul_inv]; ring)
+
+theorem referenceContactGame_distinct_le (dummy : OtsReferenceWords) (adversary : Adversary) (q : Nat)
+    (hbound : HasHashQueryBound scheme adversary q) (hsmall : q < Fintype.card Digest) :
+    Pr[fun result => result.2.2.TwoContacts result.1 (referenceFamilyWords result.2.1 dummy) |
+      referenceContactGame (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] ≤
+      (4 * ((q : ENNReal) / Fintype.card Digest) *
+        (∑' result : ReferenceRecordedResult, Pr[= result | referenceRecordedGame (canonicalGraphGameInputs adversary)
+          (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] * (result.prefixCalls dummy : ENNReal))) /
+        ((1 - (q : ENNReal) / Fintype.card Digest)^2 * (Fintype.card Digest : ENNReal)) := by
+  have hcard : (Fintype.card Digest : ENNReal) ≠ 0 := by exact_mod_cast Fintype.card_ne_zero
+  have hpositive : 0 < 1 - (q : ENNReal) / Fintype.card Digest := by
+    apply tsub_pos_iff_lt.mpr
+    rw [ENNReal.div_lt_iff (Or.inl hcard) (Or.inl (by finiteness)), one_mul]
+    exact_mod_cast hsmall
+  apply (ENNReal.le_div_iff_mul_le (Or.inl (mul_ne_zero (pow_ne_zero 2 (ne_of_gt hpositive)) hcard)) (Or.inl (by finiteness))).mpr
+  simpa only [mul_comm] using referenceContactGame_distinct_cost_le dummy adversary q hbound hsmall
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsDistinctContactProbability.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsDistinctContactProbability.lean
new file mode 100644
index 000000000..11d7a4d29
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsDistinctContactProbability.lean
@@ -0,0 +1,66 @@
+import SphincsSecurity.Proof.Ots.OtsContactProbability
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphInputs canonicalEncodingInputs canonicalGraphGameInputs OtsContactTrace.contacts Finset.univ
+
+def ContactResult.TwoContacts (parameter : PublicParameter) (words : OtsReferenceWords) (result : ContactResult) : Prop :=
+  2 ≤ (OtsContactTrace.contacts parameter words result.frontier (result.before * result.after)).card
+
+theorem contactObserver_two_contacts (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (computation : OracleComp OracleWorld (Bool × SigningBoundaryTrace)) (result : ContactResult)
+    (hresult : result ∈ support (contactObserver parameter words frontier computation))
+    (htwo : result.TwoContacts parameter words) : ∃ address, result.NewContact parameter words address := by
+  rw [contactObserver, support_map] at hresult
+  obtain ⟨split, hsplit, rfl⟩ := hresult
+  obtain ⟨hmarked, address, hbefore, hafter⟩ := OtsContactTrace.splitRun_two_contacts parameter words frontier computation split hsplit htwo
+  refine ⟨address, ⟨hmarked, hbefore⟩, ?_⟩
+  rw [OtsContactTrace.contacts_mul]
+  exact Finset.mem_union_right _ hafter
+
+theorem referenceContactGame_two_contacts (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (dummy : OtsReferenceWords) (adversary : Adversary)
+    (result : InstrumentedResult ContactResult) (hresult : result ∈ support (referenceContactGame inputs hencoding dummy adversary))
+    (htwo : result.2.2.TwoContacts result.1 (referenceFamilyWords result.2.1 dummy)) :
+    ∃ address, result.2.2.NewContact result.1 (referenceFamilyWords result.2.1 dummy) address := by
+  simp only [referenceContactGame, referenceInstrumentedGame, mem_support_bind_iff] at hresult
+  obtain ⟨parameter, _, otsSecret, _, ftsSecret, _, reference, _, output, houtput, hresult⟩ := hresult
+  rw [mem_support_pure_iff] at hresult
+  subst result
+  have hsyntax := (mem_support_iff_of_evalDist_eq (mx := referenceInstrumentedRest contactObserver _ _ _ _ dummy adversary)
+    (mx' := 𝒟[referenceInstrumentedRest contactObserver _ _ _ _ dummy adversary]) rfl output).mpr houtput
+  exact contactObserver_two_contacts _ _ _ _ output (QueryCap.simulate_oracle_mem_support _ _ output hsyntax) htwo
+
+theorem referenceContactGame_twoContacts_le_sum (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    let law := referenceContactGame inputs hencoding dummy adversary
+    Pr[fun result => result.2.2.TwoContacts result.1 (referenceFamilyWords result.2.1 dummy) | law] ≤
+      ∑ address : OtsPrefix.ChainAddress,
+        Pr[fun result => result.2.2.NewContact result.1 (referenceFamilyWords result.2.1 dummy) address | law] := by
+  dsimp only
+  let law := referenceContactGame inputs hencoding dummy adversary
+  let event := fun address : OtsPrefix.ChainAddress => fun result : InstrumentedResult ContactResult =>
+    result.2.2.NewContact result.1 (referenceFamilyWords result.2.1 dummy) address
+  refine (_root_.probEvent_mono (mx := law) (q := fun result => ∃ address ∈ (Finset.univ : Finset OtsPrefix.ChainAddress), event address result) ?_).trans
+    (probEvent_exists_finset_le_sum Finset.univ law event)
+  intro result hr ht
+  obtain ⟨address, ha⟩ := referenceContactGame_two_contacts inputs hencoding dummy adversary result hr ht
+  refine ⟨address, ?_, ha⟩
+  exact Finset.mem_univ address
+
+theorem referenceContactGame_distinct_restart_le (dummy : OtsReferenceWords) (adversary : Adversary) (budget : Nat)
+    (hbound : HasHashQueryBound scheme adversary budget) (hsmall : budget < Fintype.card Digest) :
+    let law := referenceContactGame (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary
+    ((1 - (budget : ENNReal) / Fintype.card Digest) * (Fintype.card Digest : ENNReal)) *
+      Pr[fun result => result.2.2.TwoContacts result.1 (referenceFamilyWords result.2.1 dummy) | law] ≤
+      ((2 * budget : Nat) : ENNReal) * Pr[fun result => result.2.2.Marked result.1 (referenceFamilyWords result.2.1 dummy) | law] := by
+  dsimp only
+  have hsum := Finset.sum_le_sum (s := (Finset.univ : Finset OtsPrefix.ChainAddress))
+    fun address _ => referenceContactGame_newContact_le address dummy adversary budget hbound hsmall
+  rw [← Finset.mul_sum] at hsum
+  exact (mul_le_mul' le_rfl (referenceContactGame_twoContacts_le_sum _ _ dummy adversary)).trans
+    (hsum.trans (referenceContactGame_restart_allocation dummy adversary budget hbound))
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsEncodingMarker.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsEncodingMarker.lean
new file mode 100644
index 000000000..a6fa51ca3
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsEncodingMarker.lean
@@ -0,0 +1,87 @@
+import SphincsSecurity.Proof.Ots.EncodingFreshRow
+import SphincsSecurity.Proof.Ots.EncodingBackwardWitness
+import SphincsSecurity.Proof.Ots.OtsContactTrace
+import SphincsSecurity.Proof.Reference.QueryClassAllocation
+namespace SphincsSecurity.Concrete.OtsEncodingMarker
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] Finset.univ OtsContactTrace.contacts canonicalEncodingInputs
+
+def EntryMarker (parameter : PublicParameter) (words : OtsReferenceWords) (address : OtsPrefix.ChainAddress)
+    (entry : HashInput × HashOutput) : Prop :=
+  AtEncodingPosition parameter entry.1 ⟨address.1, address.2.1, address.2.2.1⟩ ∧
+    entry.1 ∈ canonicalEncodingInputs parameter ∧
+    ∃ candidate, decodeEncodingOutput entry.2 = some candidate ∧
+      TargetSum.UnitNeighborAt (words address.1 address.2.1 address.2.2.1) candidate address.2.2.2
+
+theorem entryMarker_encoding_iff (parameter : PublicParameter) (words : OtsReferenceWords) (address : OtsPrefix.ChainAddress)
+    (message : Digest) (counter : Counter) (output : HashOutput) :
+    EntryMarker parameter words address
+      (tweakableHashInput parameter (.encoding address.1 address.2.1 address.2.2.1)
+        (digestBytes message ++ counterBytes counter), output) ↔
+      ∃ candidate, decodeEncodingOutput output = some candidate ∧
+        TargetSum.UnitNeighborAt (words address.1 address.2.1 address.2.2.1) candidate address.2.2.2 := by
+  have hcounter : counter.toNat < encodingAttemptLimit := by
+    simpa only [encodingAttemptLimit, counterBits] using counter.isLt
+  have hin := encodingRetryInput_mem_canonicalEncodingInputs parameter
+    ⟨address.1, address.2.1, address.2.2.1⟩ message ⟨counter.toNat, hcounter⟩
+  simp only [encodingRetryInput, BitVec.ofNat_toNat] at hin
+  exact and_iff_right ⟨_, rfl⟩ |>.trans (and_iff_right hin)
+
+def Seen (parameter : PublicParameter) (words : OtsReferenceWords) (address : OtsPrefix.ChainAddress)
+    (trace : OtsContactTrace.Trace) : Prop := ∃ entry ∈ trace.toList, EntryMarker parameter words address entry
+
+theorem entryMarker_unique (parameter : PublicParameter) (words : OtsReferenceWords) (entry : HashInput × HashOutput)
+    (left right : OtsPrefix.ChainAddress) (hleft : EntryMarker parameter words left entry) (hright : EntryMarker parameter words right entry) :
+    left = right := by
+  rcases left with ⟨leftLay, leftTree, leftLeaf, leftChain⟩
+  rcases right with ⟨rightLay, rightTree, rightLeaf, rightChain⟩
+  obtain ⟨hl, _, leftWord, hdecodeLeft, hneighborLeft⟩ := hleft
+  obtain ⟨hr, _, rightWord, hdecodeRight, hneighborRight⟩ := hright
+  have hp := atEncodingPosition_unique hl hr
+  simp only [EncodingPosition.mk.injEq] at hp
+  obtain ⟨rfl, rfl, rfl⟩ := hp
+  have hw : leftWord = rightWord := Option.some.inj (hdecodeLeft.symm.trans hdecodeRight)
+  subst rightWord
+  have hc := hneighborLeft.lowered_unique hneighborRight
+  cases hc
+  rfl
+
+theorem entryMarker_not_contact (parameter : PublicParameter) (words : OtsReferenceWords) (address other : OtsPrefix.ChainAddress)
+    (endpoint : Digest) (entry : HashInput × HashOutput) (hm : EntryMarker parameter words address entry) :
+    ¬OtsContactTrace.EntryContact (OtsPrefix.atAddress parameter words other) endpoint entry := by
+  intro hc
+  exact QueryClass.prefix_not_encoding (OtsPrefix.atAddress parameter words other) (.inr entry.1)
+    (OtsContactTrace.entryContact_selects _ endpoint entry hc) ⟨_, hm.1⟩
+
+theorem seen_one (parameter : PublicParameter) (words : OtsReferenceWords) (address : OtsPrefix.ChainAddress) :
+    ¬Seen parameter words address 1 := by simp [Seen]
+
+theorem seen_of (parameter : PublicParameter) (words : OtsReferenceWords) (address : OtsPrefix.ChainAddress) (entry : HashInput × HashOutput) :
+    Seen parameter words address (FreeMonoid.of entry) ↔ EntryMarker parameter words address entry := by simp [Seen]
+
+theorem seen_mul (parameter : PublicParameter) (words : OtsReferenceWords) (address : OtsPrefix.ChainAddress) (before after : OtsContactTrace.Trace) :
+    Seen parameter words address (before * after) ↔ Seen parameter words address before ∨ Seen parameter words address after := by
+  simp only [Seen, FreeMonoid.toList_mul, List.mem_append, or_and_right, exists_or]
+
+noncomputable def markers (parameter : PublicParameter) (words : OtsReferenceWords) (trace : OtsContactTrace.Trace) :
+    Finset OtsPrefix.ChainAddress := Finset.univ.filter fun address => Seen parameter words address trace
+
+theorem mem_markers (parameter : PublicParameter) (words : OtsReferenceWords) (trace : OtsContactTrace.Trace) (address : OtsPrefix.ChainAddress) :
+    address ∈ markers parameter words trace ↔ Seen parameter words address trace := by
+  simp only [markers, Finset.mem_filter, Finset.mem_univ, true_and]
+
+theorem markers_one (parameter : PublicParameter) (words : OtsReferenceWords) : markers parameter words 1 = ∅ := by
+  ext address
+  simp only [mem_markers, seen_one, Finset.notMem_empty]
+
+theorem markers_mul (parameter : PublicParameter) (words : OtsReferenceWords) (before after : OtsContactTrace.Trace) :
+    markers parameter words (before * after) = markers parameter words before ∪ markers parameter words after := by
+  ext address
+  simp only [mem_markers, seen_mul, Finset.mem_union]
+
+attribute [local irreducible] markers
+
+end SphincsSecurity.Concrete.OtsEncodingMarker
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsEndpointLikelihood.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsEndpointLikelihood.lean
new file mode 100644
index 000000000..6176fc38d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsEndpointLikelihood.lean
@@ -0,0 +1,47 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Chains.AdaptiveChainEndpoint
+import SphincsSecurity.Proof.Hypertree.Extract
+import SphincsSecurity.Proof.Ots.OneTime
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] chainWalk
+noncomputable local instance instDecidableEqQueryImplHashInputHashSpecId : DecidableEq (QueryImpl HashSpec Id) := Classical.decEq _
+
+noncomputable def otsChainFunctions (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex)
+    (leaf : LeafIndex) (chainIdx : ChainIndex) (start steps : Nat) (f : QueryImpl HashSpec Id) :
+    Fin steps → Digest → Digest :=
+  fun step value => evalWithAnswerFn f (chainWalk parameter lay tree leaf chainIdx (start + step.val) 1 value)
+
+theorem otsChainFunctions_tail (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex)
+    (leaf : LeafIndex) (chainIdx : ChainIndex) (start steps : Nat) (f : QueryImpl HashSpec Id) :
+    Fin.tail (otsChainFunctions parameter lay tree leaf chainIdx start (steps + 1) f) =
+      otsChainFunctions parameter lay tree leaf chainIdx (start + 1) steps f := by
+  funext step value
+  simp only [Fin.tail, otsChainFunctions, Fin.val_succ, Nat.add_right_comm start 1 step.val,
+    Nat.add_assoc]
+
+theorem otsChainFunctions_apply (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex)
+    (leaf : LeafIndex) (chainIdx : ChainIndex) (start steps : Nat) (f : QueryImpl HashSpec Id)
+    (step : Fin steps) (hstep : start + step.val < chainLength - 1) (value : Digest) :
+    otsChainFunctions parameter lay tree leaf chainIdx start steps f step value =
+      truncateHash (f (tweakableHashInput parameter (.chain lay tree leaf chainIdx ⟨start + step.val, hstep⟩)
+        (digestBytes value))) := by
+  simp only [otsChainFunctions, chainWalk, Nat.add_zero, evalWithAnswerFn_bind, evalWithAnswerFn_pure,
+    dif_pos hstep, eval_tweakableHash]
+
+theorem otsChainFunctions_evaluate (parameter : PublicParameter) (lay : Layer) (tree : TreeIndex)
+    (leaf : LeafIndex) (chainIdx : ChainIndex) (start steps : Nat) (f : QueryImpl HashSpec Id) (value : Digest) :
+    PartialChainEndpoint.evaluate (otsChainFunctions parameter lay tree leaf chainIdx start steps f) value =
+      evalWithAnswerFn f (chainWalk parameter lay tree leaf chainIdx start steps value) := by
+  induction steps generalizing start value with
+  | zero => simp only [PartialChainEndpoint.evaluate, chainWalk, evalWithAnswerFn_pure]
+  | succ steps ih =>
+      rw [PartialChainEndpoint.evaluate, otsChainFunctions_tail, ih]
+      change evalWithAnswerFn f (chainWalk parameter lay tree leaf chainIdx (start + 1) steps
+        (evalWithAnswerFn f (chainWalk parameter lay tree leaf chainIdx start 1 value))) = _
+      simpa only [Nat.add_comm 1 steps] using
+        (eval_chainWalk_add f parameter lay tree leaf chainIdx start 1 steps value).symm
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsMarkerContactBound.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsMarkerContactBound.lean
new file mode 100644
index 000000000..ab88ac0dd
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsMarkerContactBound.lean
@@ -0,0 +1,46 @@
+import SphincsSecurity.Proof.Ots.OtsMarkerContactSource
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphInputs canonicalEncodingInputs canonicalGraphGameInputs Finset.univ
+
+private theorem sum_membership_probability {Address Result : Type} [Fintype Address] [DecidableEq Address]
+    (law : SPMF Result) (marked : Result → Finset Address) :
+    (∑ address : Address, Pr[fun result => address ∈ marked result | law]) =
+      ∑' result, Pr[= result | law] * ((marked result).card : ENNReal) := by
+  rw [← tsum_fintype (L := SummationFilter.unconditional Address)]
+  simp only [probEvent_eq_tsum_ite]
+  rw [ENNReal.tsum_comm]
+  apply tsum_congr
+  intro result
+  rw [tsum_fintype, Fintype.sum_ite_mem, Finset.sum_const, nsmul_eq_mul, mul_comm]
+
+theorem referenceContactGame_sum_marker_probability (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (∑ address : OtsPrefix.ChainAddress, Pr[fun result => OtsEncodingMarker.Seen result.1 (referenceFamilyWords result.2.1 dummy) address
+      (result.2.2.before * result.2.2.after) | referenceContactGame inputs hencoding dummy adversary]) =
+      ∑' result, Pr[= result | referenceContactGame inputs hencoding dummy adversary] *
+        ((OtsEncodingMarker.markers result.1 (referenceFamilyWords result.2.1 dummy) (result.2.2.before * result.2.2.after)).card : ENNReal) := by
+  simpa only [OtsEncodingMarker.mem_markers] using sum_membership_probability
+    (referenceContactGame inputs hencoding dummy adversary)
+    (fun result => OtsEncodingMarker.markers result.1 (referenceFamilyWords result.2.1 dummy) (result.2.2.before * result.2.2.after))
+
+theorem markerCheckpointGame_contact_shared_bound (dummy : OtsReferenceWords) (adversary : Adversary) (budget : Nat)
+    (hbound : HasHashQueryBound scheme adversary budget) (hsmall : budget < Fintype.card Digest) :
+    ((1 - (budget : ENNReal) / Fintype.card Digest) * (Fintype.card Digest : ENNReal)) *
+      (∑ address : OtsPrefix.ChainAddress,
+        Pr[fun result => result.2.2.ContactAfterStop (OtsEncodingMarker.stopAt address) result.1 (referenceFamilyWords result.2.1 dummy) address |
+          markerCheckpointGame address (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary]) ≤
+      (3444 * ((budget : ENNReal) / Fintype.card Digest)) * ∑' result,
+        Pr[= result | referenceRecordedGame (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] *
+          (result.encodingCalls : ENNReal) := by
+  have hsum := Finset.sum_le_sum (s := (Finset.univ : Finset OtsPrefix.ChainAddress))
+    (fun address _ => markerCheckpointGame_contact_le_marker address dummy adversary budget hbound hsmall)
+  rw [← Finset.mul_sum, ← Finset.mul_sum, referenceContactGame_sum_marker_probability] at hsum
+  refine hsum.trans ((mul_le_mul' le_rfl (referenceContactGame_markers_le_encodingCost dummy adversary)).trans_eq ?_)
+  simp only [Nat.cast_mul, Nat.cast_ofNat, div_eq_mul_inv]
+  ring
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsMarkerContactPartition.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsMarkerContactPartition.lean
new file mode 100644
index 000000000..afd85aeec
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsMarkerContactPartition.lean
@@ -0,0 +1,109 @@
+import SphincsSecurity.Proof.Ots.OtsMarkerContactSource
+import SphincsSecurity.Proof.Ots.OtsContactMarkerTrace
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] OtsContactTrace.contacts canonicalEncodingInputs Finset.univ
+
+namespace OtsEncodingMarker
+
+theorem ContactBeforeMarker.mul_right {parameter : PublicParameter} {words : OtsReferenceWords}
+    {frontier : OtsFrontierValues} {trace : OtsContactTrace.Trace}
+    (h : ContactBeforeMarker parameter words frontier trace) (tail : OtsContactTrace.Trace) :
+    ContactBeforeMarker parameter words frontier (trace * tail) := by
+  obtain ⟨before, entry, after, he, hm⟩ := h
+  refine ⟨before, entry, after ++ tail.toList, ?_, hm⟩
+  simp only [FreeMonoid.toList_mul, he, List.append_assoc, List.cons_append]
+
+theorem contactBeforeMarker_of_newMarker (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (history : OtsContactTrace.Trace) (address : OtsPrefix.ChainAddress) (entry : HashInput × HashOutput)
+    (hc : address ∈ OtsContactTrace.contacts parameter words frontier history) (hm : NewMarker parameter words history address entry) :
+    ContactBeforeMarker parameter words frontier (history * FreeMonoid.of entry) := by
+  refine ⟨history.toList, entry, [], ?_, ?_⟩
+  · simp only [FreeMonoid.toList_mul, FreeMonoid.toList_of]
+  · exact ⟨address, hc, hm⟩
+
+theorem markerPause_contact_first {Result : Type} (parameter : PublicParameter) (words : OtsReferenceWords)
+    (frontier : OtsFrontierValues) (address : OtsPrefix.ChainAddress) (computation : OracleComp OracleWorld Result)
+    (result : OtsContactTrace.Trace × OracleComp OracleWorld Result)
+    (hr : result ∈ support (QueryPause.run (stopAt address parameter words frontier)
+      (fun input answer history => history * hashObservationTrace input answer) computation 1))
+    (hm : Seen parameter words address result.1) (hc : address ∈ OtsContactTrace.contacts parameter words frontier result.1) :
+    ContactBeforeMarker parameter words frontier result.1 := by
+  have h := QueryPause.run_invariant (stopAt address parameter words frontier)
+    (fun input answer history => history * hashObservationTrace input answer)
+    (fun history => Seen parameter words address history → address ∈ OtsContactTrace.contacts parameter words frontier history →
+      ContactBeforeMarker parameter words frontier history) ?_ computation 1 ?_ result hr
+  · exact h hm hc
+  · intro history _ hn input answer hm hc
+    cases input with
+    | inl input =>
+        simp only [hashObservationTrace, mul_one] at hm
+        exact False.elim (hn hm)
+    | inr input =>
+        have he : EntryMarker parameter words address (input, answer) :=
+          (seen_of _ _ _ _).mp (((seen_mul _ _ _ _ _).mp hm).resolve_left hn)
+        rw [hashObservationTrace, OtsContactTrace.contacts_mul, Finset.mem_union] at hc
+        rcases hc with hc | hc
+        · exact contactBeforeMarker_of_newMarker parameter words frontier history address (input, answer) hc ⟨he, hn⟩
+        · exact False.elim (entryMarker_not_contact parameter words address address _ (input, answer) he
+            ((OtsContactTrace.seen_of _ _ _).mp ((OtsContactTrace.mem_contacts _ _ _ _ _).mp hc)))
+  · exact fun hm _ => False.elim (seen_one parameter words address hm)
+
+theorem markerSplitRun_partition {Result : Type} (parameter : PublicParameter) (words : OtsReferenceWords)
+    (frontier : OtsFrontierValues) (address : OtsPrefix.ChainAddress) (computation : OracleComp OracleWorld Result)
+    (result : OtsContactTrace.Trace × (Result × OtsContactTrace.Trace))
+    (hr : result ∈ support (checkpointSplitRun (stopAt address) parameter words frontier computation))
+    (hm : Seen parameter words address (result.1 * result.2.2))
+    (hn : ¬ContactBeforeMarker parameter words frontier (result.1 * result.2.2)) :
+    Seen parameter words address result.1 ∧ address ∉ OtsContactTrace.contacts parameter words frontier result.1 := by
+  simp only [checkpointSplitRun, mem_support_bind_iff, mem_support_pure_iff] at hr
+  obtain ⟨middle, hmiddle, tail, htail, rfl⟩ := hr
+  have hbefore : Seen parameter words address middle.1 := by
+    rcases QueryPause.run_stopped_or_finished (stopAt address parameter words frontier)
+      (fun input answer history => history * hashObservationTrace input answer) computation 1 middle hmiddle with hs | ⟨value, hv⟩
+    · exact hs
+    · rw [hv, QueryPause.traced_pure, mem_support_pure_iff] at htail
+      subst tail
+      simpa only [mul_one] using hm
+  refine ⟨hbefore, fun hc => hn ?_⟩
+  exact (markerPause_contact_first parameter words frontier address computation middle hmiddle hbefore hc).mul_right tail.2
+
+end OtsEncodingMarker
+
+def ContactResult.MarkerContact (parameter : PublicParameter) (words : OtsReferenceWords) (result : ContactResult) : Prop :=
+  ∃ address, OtsEncodingMarker.Seen parameter words address (result.before * result.after) ∧
+    address ∈ OtsContactTrace.contacts parameter words result.frontier (result.before * result.after)
+
+theorem markerObserver_partition (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (address : OtsPrefix.ChainAddress) (computation : OracleComp OracleWorld (Bool × SigningBoundaryTrace))
+    (result : ContactResult) (hr : result ∈ support (checkpointObserver (OtsEncodingMarker.stopAt address) parameter words frontier computation))
+    (hm : OtsEncodingMarker.Seen parameter words address (result.before * result.after))
+    (hc : address ∈ OtsContactTrace.contacts parameter words result.frontier (result.before * result.after))
+    (hn : ¬OtsEncodingMarker.ContactBeforeMarker parameter words result.frontier (result.before * result.after)) :
+    result.ContactAfterStop (OtsEncodingMarker.stopAt address) parameter words address := by
+  rw [checkpointObserver, support_map] at hr
+  obtain ⟨split, hs, rfl⟩ := hr
+  exact ⟨OtsEncodingMarker.markerSplitRun_partition parameter words frontier address computation split hs hm hn, hc⟩
+
+theorem markerCheckpointGame_partition (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (address : OtsPrefix.ChainAddress)
+    (dummy : OtsReferenceWords) (adversary : Adversary) (result : InstrumentedResult ContactResult)
+    (hr : result ∈ support (markerCheckpointGame address inputs hencoding dummy adversary))
+    (hm : OtsEncodingMarker.Seen result.1 (referenceFamilyWords result.2.1 dummy) address (result.2.2.before * result.2.2.after))
+    (hc : address ∈ OtsContactTrace.contacts result.1 (referenceFamilyWords result.2.1 dummy) result.2.2.frontier (result.2.2.before * result.2.2.after))
+    (hn : ¬OtsEncodingMarker.ContactBeforeMarker result.1 (referenceFamilyWords result.2.1 dummy) result.2.2.frontier
+      (result.2.2.before * result.2.2.after)) :
+    result.2.2.ContactAfterStop (OtsEncodingMarker.stopAt address) result.1 (referenceFamilyWords result.2.1 dummy) address := by
+  simp only [markerCheckpointGame, referenceInstrumentedGame, mem_support_bind_iff] at hr
+  obtain ⟨parameter, _, otsSecret, _, ftsSecret, _, reference, _, output, houtput, hr⟩ := hr
+  rw [mem_support_pure_iff] at hr
+  subst result
+  have hsyntax := (mem_support_iff_of_evalDist_eq
+    (mx := referenceInstrumentedRest (checkpointObserver (OtsEncodingMarker.stopAt address)) _ _ _ _ dummy adversary)
+    (mx' := 𝒟[referenceInstrumentedRest (checkpointObserver (OtsEncodingMarker.stopAt address)) _ _ _ _ dummy adversary]) rfl output).mpr houtput
+  exact markerObserver_partition _ _ _ address _ output (QueryCap.simulate_oracle_mem_support _ _ output hsyntax) hm hc hn
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsMarkerContactProbability.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsMarkerContactProbability.lean
new file mode 100644
index 000000000..40410cf02
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsMarkerContactProbability.lean
@@ -0,0 +1,97 @@
+import SphincsSecurity.Proof.Ots.OtsMarkerContactPartition
+import SphincsSecurity.Proof.Ots.OtsMarkerContactBound
+import SphincsSecurity.Proof.Ots.OtsContactMarkerBound
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphInputs canonicalEncodingInputs canonicalGraphGameInputs Finset.univ OtsContactTrace.contacts
+
+theorem referenceContactGame_marker_residual_le_checkpoint (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (address : OtsPrefix.ChainAddress)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    Pr[fun result => (OtsEncodingMarker.Seen result.1 (referenceFamilyWords result.2.1 dummy) address (result.2.2.before * result.2.2.after) ∧
+      address ∈ OtsContactTrace.contacts result.1 (referenceFamilyWords result.2.1 dummy) result.2.2.frontier (result.2.2.before * result.2.2.after)) ∧
+        ¬OtsEncodingMarker.ContactBeforeMarker result.1 (referenceFamilyWords result.2.1 dummy) result.2.2.frontier
+          (result.2.2.before * result.2.2.after) | referenceContactGame inputs hencoding dummy adversary] ≤
+      Pr[fun result => result.2.2.ContactAfterStop (OtsEncodingMarker.stopAt address) result.1 (referenceFamilyWords result.2.1 dummy) address |
+        markerCheckpointGame address inputs hencoding dummy adversary] := by
+  have h := congrArg (fun law : SPMF (PublicParameter × ReferenceFamily × OtsFrontierValues × (Bool × SigningBoundaryTrace) × OtsContactTrace.Trace) =>
+    Pr[fun result => (OtsEncodingMarker.Seen result.1 (referenceFamilyWords result.2.1 dummy) address result.2.2.2.2 ∧
+      address ∈ OtsContactTrace.contacts result.1 (referenceFamilyWords result.2.1 dummy) result.2.2.1 result.2.2.2.2) ∧
+        ¬OtsEncodingMarker.ContactBeforeMarker result.1 (referenceFamilyWords result.2.1 dummy) result.2.2.1 result.2.2.2.2 | law])
+    (referenceCheckpointGame_frontier_trace (OtsEncodingMarker.stopAt address) inputs hencoding dummy adversary)
+  simp only [probEvent_map, Function.comp_def] at h
+  rw [← h]
+  exact _root_.probEvent_mono fun result hr he =>
+    markerCheckpointGame_partition inputs hencoding address dummy adversary result hr he.1.1 he.1.2 he.2
+
+theorem referenceContactGame_markerContact_partition (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    Pr[fun result => result.2.2.MarkerContact result.1 (referenceFamilyWords result.2.1 dummy) |
+      referenceContactGame inputs hencoding dummy adversary] ≤
+      Pr[fun result => OtsEncodingMarker.ContactBeforeMarker result.1 (referenceFamilyWords result.2.1 dummy) result.2.2.frontier
+        (result.2.2.before * result.2.2.after) | referenceContactGame inputs hencoding dummy adversary] +
+      ∑ address : OtsPrefix.ChainAddress,
+        Pr[fun result => result.2.2.ContactAfterStop (OtsEncodingMarker.stopAt address) result.1 (referenceFamilyWords result.2.1 dummy) address |
+          markerCheckpointGame address inputs hencoding dummy adversary] := by
+  let law := referenceContactGame inputs hencoding dummy adversary
+  let bad := fun result : InstrumentedResult ContactResult =>
+    OtsEncodingMarker.ContactBeforeMarker result.1 (referenceFamilyWords result.2.1 dummy) result.2.2.frontier (result.2.2.before * result.2.2.after)
+  let residual := fun address : OtsPrefix.ChainAddress => fun result : InstrumentedResult ContactResult =>
+    (OtsEncodingMarker.Seen result.1 (referenceFamilyWords result.2.1 dummy) address (result.2.2.before * result.2.2.after) ∧
+      address ∈ OtsContactTrace.contacts result.1 (referenceFamilyWords result.2.1 dummy) result.2.2.frontier (result.2.2.before * result.2.2.after)) ∧
+        ¬bad result
+  have hsplit : Pr[fun result => result.2.2.MarkerContact result.1 (referenceFamilyWords result.2.1 dummy) | law] ≤
+      Pr[bad | law] + Pr[fun result => ∃ address ∈ (Finset.univ : Finset OtsPrefix.ChainAddress), residual address result | law] := by
+    refine (_root_.probEvent_mono (q := fun result => bad result ∨
+      ∃ address ∈ (Finset.univ : Finset OtsPrefix.ChainAddress), residual address result) ?_).trans (probEvent_or_le _ _ _)
+    intro result _ hm
+    by_cases hb : bad result
+    · exact Or.inl hb
+    · obtain ⟨address, hm, hc⟩ := hm
+      exact Or.inr ⟨address, Finset.mem_univ address, ⟨hm, hc⟩, hb⟩
+  refine hsplit.trans (add_le_add le_rfl ?_)
+  refine (probEvent_exists_finset_le_sum Finset.univ law residual).trans (Finset.sum_le_sum ?_)
+  intro address _
+  exact referenceContactGame_marker_residual_le_checkpoint inputs hencoding address dummy adversary
+
+theorem referenceContactGame_markerContact_shared_bound (dummy : OtsReferenceWords) (adversary : Adversary) (budget : Nat)
+    (hbound : HasHashQueryBound scheme adversary budget) (hsmall : budget < Fintype.card Digest) :
+    ((1 - (budget : ENNReal) / Fintype.card Digest) * (Fintype.card Digest : ENNReal)) *
+      Pr[fun result => result.2.2.MarkerContact result.1 (referenceFamilyWords result.2.1 dummy) |
+        referenceContactGame (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] ≤
+      (82 * ((budget : ENNReal) / Fintype.card Digest)) * (∑' result,
+        Pr[= result | referenceRecordedGame (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] *
+          (result.prefixCalls dummy : ENNReal)) +
+      (3444 * ((budget : ENNReal) / Fintype.card Digest)) * (∑' result,
+        Pr[= result | referenceRecordedGame (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] *
+          (result.encodingCalls : ENNReal)) := by
+  have h := mul_le_mul' (le_refl ((1 - (budget : ENNReal) / Fintype.card Digest) * (Fintype.card Digest : ENNReal)))
+    (referenceContactGame_markerContact_partition (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary)
+  rw [mul_add] at h
+  exact h.trans (add_le_add (referenceContactGame_contactMarker_shared_bound dummy adversary budget hbound hsmall)
+    (markerCheckpointGame_contact_shared_bound dummy adversary budget hbound hsmall))
+
+theorem referenceContactGame_markerContact_le (dummy : OtsReferenceWords) (adversary : Adversary) (budget : Nat)
+    (hbound : HasHashQueryBound scheme adversary budget) (hsmall : budget < Fintype.card Digest) :
+    Pr[fun result => result.2.2.MarkerContact result.1 (referenceFamilyWords result.2.1 dummy) |
+      referenceContactGame (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] ≤
+      ((82 * ((budget : ENNReal) / Fintype.card Digest)) * (∑' result,
+        Pr[= result | referenceRecordedGame (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] *
+          (result.prefixCalls dummy : ENNReal)) +
+       (3444 * ((budget : ENNReal) / Fintype.card Digest)) * (∑' result,
+        Pr[= result | referenceRecordedGame (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] *
+          (result.encodingCalls : ENNReal))) /
+        ((1 - (budget : ENNReal) / Fintype.card Digest) * (Fintype.card Digest : ENNReal)) := by
+  have hcard : (Fintype.card Digest : ENNReal) ≠ 0 := by exact_mod_cast Fintype.card_ne_zero
+  have hpositive : 0 < 1 - (budget : ENNReal) / Fintype.card Digest := by
+    apply tsub_pos_iff_lt.mpr
+    rw [ENNReal.div_lt_iff (Or.inl hcard) (Or.inl (by finiteness)), one_mul]
+    exact_mod_cast hsmall
+  apply (ENNReal.le_div_iff_mul_le (Or.inl (mul_ne_zero (ne_of_gt hpositive) hcard)) (Or.inl (by finiteness))).mpr
+  simpa only [mul_comm] using referenceContactGame_markerContact_shared_bound dummy adversary budget hbound hsmall
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsMarkerContactSource.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsMarkerContactSource.lean
new file mode 100644
index 000000000..6772bfcf7
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsMarkerContactSource.lean
@@ -0,0 +1,75 @@
+import SphincsSecurity.Proof.Ots.OtsTraceProbability
+import SphincsSecurity.Proof.Ots.EncodingMarkerAllocation
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphInputs canonicalEncodingInputs canonicalGraphGameInputs Finset.univ
+
+theorem referenceCheckpointRest_frontier_trace (stop : FrontierStop)
+    [∀ parameter words frontier, DecidablePred (stop parameter words frontier)] (key : SecretKey) (oracle : QueryImpl HashSpec Id)
+    (labels : CanonicalGraphLabels) (selections : ReferenceFamily) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (fun result : ContactResult => (result.frontier, result.output, result.before * result.after)) <$>
+      referenceInstrumentedRest (checkpointObserver stop) key oracle labels selections dummy adversary =
+        (fun result : ContactResult => (result.frontier, result.output, result.before * result.after)) <$>
+          referenceInstrumentedRest contactObserver key oracle labels selections dummy adversary := by
+  rw [referenceInstrumentedRest, referenceInstrumentedRest, ← simulateQ_map, ← simulateQ_map,
+    checkpointObserver_frontier_trace, contactObserver_frontier_trace]
+
+theorem referenceCheckpointGame_frontier_trace (stop : FrontierStop)
+    [∀ parameter words frontier, DecidablePred (stop parameter words frontier)] (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (fun result : InstrumentedResult ContactResult => (result.1, result.2.1, result.2.2.frontier, result.2.2.output, result.2.2.before * result.2.2.after)) <$>
+        referenceInstrumentedGame (checkpointObserver stop) inputs hencoding dummy adversary =
+      (fun result : InstrumentedResult ContactResult => (result.1, result.2.1, result.2.2.frontier, result.2.2.output, result.2.2.before * result.2.2.after)) <$>
+        referenceContactGame inputs hencoding dummy adversary := by
+  unfold referenceContactGame referenceInstrumentedGame
+  simp only [map_bind, map_pure]
+  apply congrArg (𝒟[sampleParameter] >>= ·)
+  funext parameter
+  apply congrArg (𝒟[sampleOtsSecrets] >>= ·)
+  funext otsSecret
+  apply congrArg (𝒟[sampleFtsSecrets] >>= ·)
+  funext ftsSecret
+  apply congrArg (𝒟[referenceFamilyOracleSample _ inputs (hencoding parameter)] >>= ·)
+  funext reference
+  have h := congrArg (fun law => (fun result => (parameter, reference.1, result.1, result.2)) <$> 𝒟[law])
+    (referenceCheckpointRest_frontier_trace stop ⟨parameter, 0, otsSecret, ftsSecret⟩ (finiteHashAnswer ∅ inputs reference.2)
+      (canonicalGraphLabels parameter otsSecret ftsSecret (finiteHashAnswer ∅ inputs reference.2)) reference.1 dummy adversary)
+  simpa only [← bind_pure_comp, evalDist_bind, evalDist_pure, bind_assoc, pure_bind] using h
+
+def OtsEncodingMarker.stopAt (address : OtsPrefix.ChainAddress) : FrontierStop :=
+  fun parameter words _ trace => OtsEncodingMarker.Seen parameter words address trace
+
+noncomputable abbrev markerCheckpointGame (address : OtsPrefix.ChainAddress) (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (dummy : OtsReferenceWords) (adversary : Adversary) :=
+  referenceInstrumentedGame (checkpointObserver (OtsEncodingMarker.stopAt address)) inputs hencoding dummy adversary
+
+theorem markerCheckpointGame_marker_probability (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (address : OtsPrefix.ChainAddress)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    Pr[fun result => OtsEncodingMarker.Seen result.1 (referenceFamilyWords result.2.1 dummy) address (result.2.2.before * result.2.2.after) |
+      markerCheckpointGame address inputs hencoding dummy adversary] =
+    Pr[fun result => OtsEncodingMarker.Seen result.1 (referenceFamilyWords result.2.1 dummy) address (result.2.2.before * result.2.2.after) |
+      referenceContactGame inputs hencoding dummy adversary] := by
+  have h := congrArg (fun law : SPMF (PublicParameter × ReferenceFamily × OtsFrontierValues × (Bool × SigningBoundaryTrace) × OtsContactTrace.Trace) =>
+    Pr[fun result => OtsEncodingMarker.Seen result.1 (referenceFamilyWords result.2.1 dummy) address result.2.2.2.2 | law])
+    (referenceCheckpointGame_frontier_trace (OtsEncodingMarker.stopAt address) inputs hencoding dummy adversary)
+  simpa only [probEvent_map, Function.comp_def] using h
+
+theorem markerCheckpointGame_contact_le_marker (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords)
+    (adversary : Adversary) (budget : Nat) (hbound : HasHashQueryBound scheme adversary budget)
+    (hsmall : budget < Fintype.card Digest) :
+    ((1 - (budget : ENNReal) / Fintype.card Digest) * (Fintype.card Digest : ENNReal)) *
+      Pr[fun result => result.2.2.ContactAfterStop (OtsEncodingMarker.stopAt address) result.1 (referenceFamilyWords result.2.1 dummy) address |
+        markerCheckpointGame address (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] ≤
+      (2 * budget : Nat) * Pr[fun result => OtsEncodingMarker.Seen result.1 (referenceFamilyWords result.2.1 dummy) address
+        (result.2.2.before * result.2.2.after) | referenceContactGame (canonicalGraphGameInputs adversary)
+          (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] := by
+  have h := referenceCheckpointGame_newContact_le_mark (OtsEncodingMarker.stopAt address) address dummy adversary budget hbound hsmall
+  refine h.trans (mul_le_mul' le_rfl ?_)
+  rw [← markerCheckpointGame_marker_probability]
+  exact _root_.probEvent_mono (fun result _ hm => (OtsEncodingMarker.seen_mul _ _ _ _ _).mpr (Or.inl hm))
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixAccounting.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixAccounting.lean
new file mode 100644
index 000000000..d884faefb
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixAccounting.lean
@@ -0,0 +1,102 @@
+import SphincsSecurity.Proof.Ots.OtsPrefixSeedGame
+import SphincsSecurity.Proof.Base.QueryCapAccounting
+namespace SphincsSecurity.Concrete.OtsPrefix
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] frontierSigningRun boundaryEval frontierRoot
+
+theorem worldImpl_queryBound (segment : OtsPrefix) (high : segment.Query → High)
+    (outside : QueryImpl HashSpec Id) (input : OracleWorld.Domain) :
+    (segment.worldImpl high outside input).IsQueryBoundP PartialChainEndpoint.IsPrefixQuery
+      (if input matches .inr _ then 1 else 0) := by
+  cases input with
+  | inl input =>
+      simp only [worldImpl, isQueryBoundP_query_iff, PartialChainEndpoint.IsPrefixQuery, false_implies]
+  | inr bytes => exact segment.hashImpl_queryBound high outside bytes
+
+private theorem withTrace_run {Input Target Trace : Type} {spec : OracleSpec Input} {target : OracleSpec Target} [Monoid Trace]
+    (impl : QueryImpl spec (OracleComp target)) (trace : (input : spec.Domain) → spec.Range input → Trace) (input : spec.Domain) :
+    (impl.withTrace trace input).run = (fun answer => (answer, trace input answer)) <$> impl input := by
+  simp [QueryImpl.withTrace_apply, WriterT.run_bind, WriterT.run_tell]
+
+theorem worldTrace_counted_le (segment : OtsPrefix) (high : segment.Query → High) (outside : QueryImpl HashSpec Id)
+    (input : OracleWorld.Domain) (result : (OracleWorld.Range input × SigningBoundaryTrace) × Nat)
+    (hresult : result ∈ support (QueryCap.counted PartialChainEndpoint.IsPrefixQuery
+      ((segment.worldImpl high outside).withTrace (signingBoundaryTrace segment.parameter) input).run)) :
+    result.2 ≤ result.1.2.hashCalls := by
+  rw [withTrace_run, QueryCap.counted_map, support_map] at hresult
+  obtain ⟨original, horiginal, rfl⟩ := hresult
+  rw [signingBoundaryTrace_hashCalls_eq]
+  have h := QueryCap.counted_le_of_queryBound _ _ _ (segment.worldImpl_queryBound high outside input) original horiginal
+  cases input <;> exact h
+
+theorem boundary_counted_le (segment : OtsPrefix) (high : segment.Query → High) (outside : QueryImpl HashSpec Id)
+    {Result : Type} (computation : OracleComp OracleWorld Result) (result : (Result × SigningBoundaryTrace) × Nat)
+    (hresult : result ∈ support (QueryCap.counted PartialChainEndpoint.IsPrefixQuery (segment.boundary high outside computation))) :
+    result.2 ≤ result.1.2.hashCalls :=
+  QueryCap.counted_writer_simulate_le _ SigningBoundaryTrace.hashCalls SigningBoundaryTrace.hashCalls_mul _
+    (segment.worldTrace_counted_le high outside) computation result hresult
+
+theorem adversaryImpl_counted_le (segment : OtsPrefix) (root : Digest) (high : segment.Query → High)
+    (outside : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) (input : (OracleWorld + SigningSpec).Domain)
+    (result : ((OracleWorld + SigningSpec).Range input × SigningBoundaryTrace) × Nat)
+    (hresult : result ∈ support (QueryCap.counted PartialChainEndpoint.IsPrefixQuery
+      (segment.adversaryImpl root high outside ftsSecret words frontier input).run)) : result.2 ≤ result.1.2.hashCalls := by
+  cases input with
+  | inl input => exact segment.worldTrace_counted_le high outside input result hresult
+  | inr message =>
+      rw [segment.adversaryImpl_signing, WriterT.run_mk] at hresult
+      have hzero := QueryCap.counted_le_of_queryBound _ _ 0 (segment.lift_prob_queryBound _) result hresult
+      exact hzero.trans (Nat.zero_le _)
+
+theorem adversaryRun_counted_le (segment : OtsPrefix) (root : Digest) (high : segment.Query → High)
+    (outside : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) {Result : Type}
+    (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (result : ((Result × QueryLog SigningSpec) × SigningBoundaryTrace) × Nat)
+    (hresult : result ∈ support (QueryCap.counted PartialChainEndpoint.IsPrefixQuery
+      (segment.adversaryRun root high outside ftsSecret words frontier computation))) : result.2 ≤ result.1.2.hashCalls :=
+  QueryCap.counted_writer_simulate_le _ SigningBoundaryTrace.hashCalls SigningBoundaryTrace.hashCalls_mul _
+    (segment.adversaryImpl_counted_le root high outside ftsSecret words frontier) (logged computation) result hresult
+
+theorem gameRest_counted_le (segment : OtsPrefix) (root : Digest) (high : segment.Query → High)
+    (outside : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) (adversary : Adversary)
+    (result : (Bool × SigningBoundaryTrace) × Nat)
+    (hresult : result ∈ support (QueryCap.counted PartialChainEndpoint.IsPrefixQuery
+      (segment.gameRest root high outside ftsSecret words frontier adversary))) : result.2 ≤ result.1.2.hashCalls := by
+  simp only [gameRest, QueryCap.counted_bind, QueryCap.counted_pure, bind_assoc, pure_bind, Nat.add_zero] at hresult
+  rw [mem_support_bind_iff] at hresult
+  obtain ⟨first, hfirst, hresult⟩ := hresult
+  rw [mem_support_bind_iff] at hresult
+  obtain ⟨second, hsecond, hresult⟩ := hresult
+  rw [mem_support_pure_iff] at hresult
+  subst result
+  rw [SigningBoundaryTrace.hashCalls_mul]
+  exact Nat.add_le_add (segment.adversaryRun_counted_le root high outside ftsSecret words frontier _ first hfirst)
+    (segment.boundary_counted_le high outside _ second hsecond)
+
+theorem game_counted_le (segment : OtsPrefix) (high : segment.Query → High) (outside : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (adversary : Adversary) (result : (Bool × SigningBoundaryTrace) × Nat)
+    (hresult : result ∈ support (QueryCap.counted PartialChainEndpoint.IsPrefixQuery
+      (segment.game high outside ftsSecret words frontier adversary))) : result.2 ≤ result.1.2.hashCalls := by
+  rw [game, QueryCap.counted_map, support_map] at hresult
+  obtain ⟨original, horiginal, rfl⟩ := hresult
+  have h := segment.gameRest_counted_le _ high outside ftsSecret words frontier adversary original horiginal
+  simp only [SigningBoundaryTrace.hashCalls_mul]
+  omega
+
+theorem seedGame_counted_le (segment : OtsPrefix) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs) (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+    (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph) (secrets : OtsFrontierValues)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (endpoint : Digest) (adversary : Adversary)
+    (result : (Bool × SigningBoundaryTrace) × Nat)
+    (hresult : result ∈ support (QueryCap.counted PartialChainEndpoint.IsPrefixQuery
+      (segment.seedGame inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary))) :
+    result.2 ≤ result.1.2.hashCalls :=
+  segment.game_counted_le _ _ ftsSecret words _ adversary result hresult
+
+end SphincsSecurity.Concrete.OtsPrefix
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixAllocation.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixAllocation.lean
new file mode 100644
index 000000000..90c8afec3
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixAllocation.lean
@@ -0,0 +1,109 @@
+import SphincsSecurity.Proof.Reference.CausalFrontierAllocation
+import SphincsSecurity.Proof.Ots.OtsPrefixFrontier
+namespace SphincsSecurity.Concrete.OtsPrefix
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] frontierSigningRun boundaryEval frontierRoot
+
+abbrev ChainAddress := Layer × TreeIndex × LeafIndex × ChainIndex
+
+abbrev atAddress (parameter : PublicParameter) (words : OtsReferenceWords) (address : ChainAddress) : OtsPrefix :=
+  ⟨parameter, address.1, address.2.1, address.2.2.1, address.2.2.2,
+    words address.1 address.2.1 address.2.2.1 address.2.2.2⟩
+
+def Selects (segment : OtsPrefix) : OracleWorld.Domain → Prop
+  | .inl _ => False
+  | .inr input => segment.parse input ≠ none
+
+noncomputable instance (segment : OtsPrefix) : DecidablePred segment.Selects := Classical.decPred _
+
+theorem atAddress_selects_unique (parameter : PublicParameter) (words : OtsReferenceWords)
+    (left right : ChainAddress) (input : OracleWorld.Domain)
+    (hleft : (atAddress parameter words left).Selects input)
+    (hright : (atAddress parameter words right).Selects input) : left = right := by
+  cases input with
+  | inl input => exact False.elim hleft
+  | inr input =>
+      obtain ⟨query, hquery⟩ := Option.ne_none_iff_exists'.mp hleft
+      have hinput := ((atAddress parameter words left).parse_some_iff input query).mp hquery
+      by_contra hne
+      have hother : ¬(atAddress parameter words right).SameChain left.1 left.2.1 left.2.2.1 left.2.2.2 := by
+        intro h
+        exact hne (Prod.ext h.1 (Prod.ext h.2.1 (Prod.ext h.2.2.1 h.2.2.2)))
+      have hnone := (atAddress parameter words right).parse_other_chain left.1 left.2.1 left.2.2.1 left.2.2.2
+        hother ((atAddress parameter words left).step query.1) query.2
+      exact hright (hinput ▸ hnone)
+
+theorem allocation_step_le (parameter : PublicParameter) (words : OtsReferenceWords) (addresses : Finset ChainAddress)
+    (input : OracleWorld.Domain) :
+    (∑ address ∈ addresses, if (atAddress parameter words address).Selects input then 1 else 0) ≤
+      if CausalFrontierProgram.IsHash input then 1 else 0 := by
+  classical
+  cases input with
+  | inl input => simp [Selects, CausalFrontierProgram.IsHash]
+  | inr input =>
+      change (∑ address ∈ addresses, if (atAddress parameter words address).Selects (.inr input) then 1 else 0) ≤ 1
+      apply Finset.sum_le_one_iff.mpr
+      intro left right _ _ hleft hright
+      have hl : (atAddress parameter words left).Selects (.inr input) := by simpa using hleft
+      have hr : (atAddress parameter words right).Selects (.inr input) := by simpa using hright
+      exact ⟨atAddress_selects_unique parameter words left right _ hl hr, if_pos hl⟩
+
+theorem allocation_le (parameter : PublicParameter) (words : OtsReferenceWords) (addresses : Finset ChainAddress)
+    (inputs : List OracleWorld.Domain) :
+    (∑ address ∈ addresses, QueryCap.calls (atAddress parameter words address).Selects inputs) ≤
+      QueryCap.calls CausalFrontierProgram.IsHash inputs :=
+  QueryCap.calls_sum_le addresses _ _ (allocation_step_le parameter words addresses) inputs
+
+theorem worldImpl_counted (segment : OtsPrefix) (tables : Fin segment.digit.val → Digest → Digest)
+    (high : segment.Query → High) (outside : QueryImpl HashSpec Id) (input : OracleWorld.Domain) :
+    simulateQ (segment.fixedImpl tables) (QueryCap.counted PartialChainEndpoint.IsPrefixQuery
+      (segment.worldImpl high outside input)) =
+      (fun answer => (answer, if segment.Selects input then 1 else 0)) <$>
+        fixedHashWorld (segment.answer tables high outside) input := by
+  cases input with
+  | inl input =>
+      simp only [worldImpl, QueryCap.counted_query, simulateQ_map, simulateQ_spec_query]
+      simp only [PartialChainEndpoint.IsPrefixQuery, Selects, if_false]
+      rfl
+  | inr bytes =>
+      cases hparse : segment.parse bytes with
+      | none => simp [worldImpl, hashImpl, hparse, QueryCap.counted_pure, Selects, fixedHashWorld, answer]
+      | some query =>
+          simp [worldImpl, hashImpl, hparse, QueryCap.counted_map, QueryCap.counted_query,
+            Selects, fixedHashWorld, answer, PartialChainEndpoint.IsPrefixQuery, fixedImpl]
+
+theorem program_mask_answer (segment : OtsPrefix) (tables : Fin segment.digit.val → Digest → Digest)
+    (high : segment.Query → High) (outside : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords)
+    (hword : segment.digit.val ≤ (words segment.lay segment.tree segment.leaf segment.chainIdx).val)
+    (frontier : OtsFrontierValues) (adversary : Adversary) :
+    CausalFrontierProgram.game segment.parameter (segment.answer tables high outside) ftsSecret words frontier adversary =
+      CausalFrontierProgram.game segment.parameter outside ftsSecret words frontier adversary := by
+  have himpl (root : Digest) : CausalFrontierProgram.adversaryImpl segment.parameter root
+      (segment.answer tables high outside) ftsSecret words frontier =
+      CausalFrontierProgram.adversaryImpl segment.parameter root outside ftsSecret words frontier := by
+    funext input
+    cases input with
+    | inl input => rfl
+    | inr message =>
+        rw [CausalFrontierProgram.adversaryImpl_signing, CausalFrontierProgram.adversaryImpl_signing,
+          segment.mask_answer words hword tables high outside]
+  simp only [CausalFrontierProgram.game, CausalFrontierProgram.gameRest, CausalFrontierProgram.adversaryRun,
+    segment.mask_answer words hword tables high outside, himpl]
+
+theorem game_counted_source (segment : OtsPrefix) (tables : Fin segment.digit.val → Digest → Digest)
+    (high : segment.Query → High) (outside : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords)
+    (hword : segment.digit.val ≤ (words segment.lay segment.tree segment.leaf segment.chainIdx).val)
+    (frontier : OtsFrontierValues) (adversary : Adversary) :
+    simulateQ (segment.fixedImpl tables) (QueryCap.counted PartialChainEndpoint.IsPrefixQuery
+        (segment.game high outside ftsSecret words frontier adversary)) =
+      simulateQ (fixedHashWorld (segment.answer tables high outside)) (QueryCap.counted segment.Selects
+        (CausalFrontierProgram.game segment.parameter (segment.answer tables high outside) ftsSecret words frontier adversary)) := by
+  rw [← CausalFrontierProgram.prefix_game, segment.program_mask_answer tables high outside ftsSecret words hword frontier adversary]
+  exact QueryCap.simulate_counted segment.Selects PartialChainEndpoint.IsPrefixQuery _ _ _
+    (segment.worldImpl_counted tables high outside) _
+
+end SphincsSecurity.Concrete.OtsPrefix
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixCheckpointCompletion.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixCheckpointCompletion.lean
new file mode 100644
index 000000000..1d14e2834
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixCheckpointCompletion.lean
@@ -0,0 +1,56 @@
+import SphincsSecurity.Proof.Ots.OtsPrefixVisibleCompletion
+import SphincsSecurity.Proof.Ots.OtsContactCheckpoint
+import SphincsSecurity.Proof.Chains.AdaptiveChainCapContact
+namespace SphincsSecurity.Concrete.OtsPrefix
+
+open _root_.OracleComp OracleSpec PartialChainEndpoint
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+
+variable (segment : OtsPrefix) (high : segment.Query → High) (auxiliary : QueryImpl OracleWorld PMF)
+  (endpoint : Digest) (stop : OtsContactTrace.Trace → Prop) [DecidablePred stop]
+  {Result : Type} (computation : OracleComp OracleWorld Result)
+
+theorem visible_checkpoint_observation
+    (middle : ((OtsContactTrace.Trace × OracleComp segment.VisibleWorld Result) × Nat) × (Fin segment.digit.val → Digest → Option Digest))
+    (hmiddle : middle ∈ (lazyRun auxiliary (QueryCap.counted IsPrefixQuery (QueryPause.run stop
+      (fun input answer history => history * segment.visibleObservationTrace high input answer)
+      (simulateQ (segment.visibleWorldImpl high) computation) 1)) (fun _ _ => none)).support)
+    (result : ((Result × OtsContactTrace.Trace) × Nat) × (Fin segment.digit.val → Digest → Option Digest))
+    (hresult : result ∈ (lazyRun auxiliary (QueryCap.counted IsPrefixQuery
+      (QueryPause.traced (segment.visibleObservationTrace high) middle.1.1.2)) middle.2).support) :
+    (OtsContactTrace.Seen segment endpoint middle.1.1.1 ↔ Contact middle.2 endpoint) ∧
+    (OtsContactTrace.Seen segment endpoint (middle.1.1.1 * result.1.1.2) ↔ Contact result.2 endpoint) ∧
+    queryCount middle.2 ≤ OtsContactTrace.prefixCalls segment middle.1.1.1 ∧
+    result.1.2 ≤ OtsContactTrace.prefixCalls segment result.1.1.2 := by
+  let paused := QueryPause.run stop (fun input answer history => history * segment.visibleObservationTrace high input answer)
+    (simulateQ (segment.visibleWorldImpl high) computation) 1
+  have hmiddle' : (middle.1.1, middle.2) ∈ (lazyRun auxiliary paused (fun _ _ => none)).support := by
+    have hforget := congrArg (fun program => lazyRun auxiliary program (fun _ _ => none)) (QueryCap.counted_forget IsPrefixQuery paused)
+    rw [lazyRun_map] at hforget
+    rw [← hforget, PMF.mem_support_map_iff]
+    exact ⟨middle, hmiddle, rfl⟩
+  have hbefore := segment.lazyRun_visible_pause_observation high auxiliary stop computation 1 (fun _ _ => none) endpoint
+    (by simp only [OtsContactTrace.seen_one, Contact, reduceCtorEq, exists_false, and_false])
+    (by simp only [queryCount_empty, OtsContactTrace.prefixCalls_one, le_refl]) (middle.1.1, middle.2) hmiddle'
+  have hcontinuation : ∃ source : OracleComp OracleWorld Result, middle.1.1.2 = simulateQ (segment.visibleWorldImpl high) source := by
+    change (middle.1.1, middle.2) ∈ (lazyRun auxiliary
+      (QueryPause.run stop (fun input answer history => history * segment.visibleObservationTrace high input answer)
+        (simulateQ (segment.visibleWorldImpl high) computation) 1) (fun _ _ => none)).support at hmiddle'
+    rw [lazyRun_visible_pause, PMF.mem_support_map_iff] at hmiddle'
+    obtain ⟨source, _, heq⟩ := hmiddle'
+    exact ⟨source.1.2, (congrArg (fun output => output.1.2) heq).symm⟩
+  have hresult' : (result.1.1, result.2) ∈ (lazyRun auxiliary
+      (QueryPause.traced (segment.visibleObservationTrace high) middle.1.1.2) middle.2).support := by
+    have hforget := congrArg (fun program => lazyRun auxiliary program middle.2)
+      (QueryCap.counted_forget IsPrefixQuery (QueryPause.traced (segment.visibleObservationTrace high) middle.1.1.2))
+    rw [lazyRun_map] at hforget
+    rw [← hforget, PMF.mem_support_map_iff]
+    exact ⟨result, hresult, rfl⟩
+  refine ⟨hbefore.1, ?_, hbefore.2, ?_⟩
+  · obtain ⟨source, hsource⟩ := hcontinuation
+    rw [hsource] at hresult'
+    exact segment.visible_traced_contact high auxiliary endpoint source middle.1.1.1 middle.2 hbefore.1 (result.1.1, result.2) hresult'
+  · exact segment.visible_traced_queries_le high middle.1.1.2 result.1 (lazyRun_result_mem auxiliary _ middle.2 result hresult)
+
+end SphincsSecurity.Concrete.OtsPrefix
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixContactProbability.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixContactProbability.lean
new file mode 100644
index 000000000..7413df7aa
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixContactProbability.lean
@@ -0,0 +1,82 @@
+import SphincsSecurity.Proof.Chains.AdaptiveChainCapObservation
+import SphincsSecurity.Proof.Reference.ReferenceQueryAllocation
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+attribute [local instance] Classical.propDecidable
+
+noncomputable def prefixContactGame (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords) (adversary : Adversary) : SPMF Bool := do
+  let parameter ← 𝒟[sampleParameter]
+  let ftsSecret ← 𝒟[sampleFtsSecrets]
+  let selections ← 𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit]
+  let words := referenceFamilyWords selections dummy
+  let segment := OtsPrefix.atAddress parameter words address
+  let other ← 𝒟[PMF.uniformOfFintype segment.ErasedSecrets]
+  let auxiliary ← 𝒟[segment.referenceAuxSeedLaw inputs (hencoding parameter) (hgraph parameter) selections]
+  let result ← 𝒟[PartialChainEndpoint.realRun (fun _ => OtsPrefix.uniformImpl)
+    (fun endpoint => segment.seedGame inputs (hencoding parameter) (hgraph parameter) auxiliary other.val ftsSecret words endpoint adversary)
+    (fun _ _ => none)]
+  pure (decide (PartialChainEndpoint.Contact result.2.2 result.1))
+
+private theorem probComp_mem_of_evalDist {Result : Type} (computation : ProbComp Result) (result : Result)
+    (hresult : result ∈ support 𝒟[computation]) : result ∈ support computation :=
+  (mem_support_iff_of_evalDist_eq (mx := computation) (mx' := 𝒟[computation]) rfl result).mpr hresult
+
+private theorem pmf_mem_of_evalDist {Result : Type} (law : PMF Result) (result : Result)
+    (hresult : result ∈ support 𝒟[law]) : result ∈ law.support := by
+  change result ∈ (𝒟[law]).support at hresult
+  simpa only [PMF.evalDist_eq, SPMF.support_liftM] using hresult
+
+theorem prefixContactGame_le (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords)
+    (adversary : Adversary) (q : Nat) (hbound : HasHashQueryBound scheme adversary q) (hsmall : q < Fintype.card Digest) :
+    Pr[= true | prefixContactGame (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) (canonicalGraphInputs_subset_gameInputs adversary) address dummy adversary] ≤
+      (2 / Fintype.card Digest) * ∑' count, Pr[= count | prefixIdealCostGame (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary) (canonicalGraphInputs_subset_gameInputs adversary)
+        address dummy adversary q] * (count : ENNReal) := by
+  have h : 1 * (∑' result, Pr[= result | prefixContactGame (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) (canonicalGraphInputs_subset_gameInputs adversary) address dummy adversary] *
+        (if result = true then 1 else 0)) ≤
+      ∑' count, Pr[= count | prefixIdealCostGame (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary) (canonicalGraphInputs_subset_gameInputs adversary)
+        address dummy adversary q] * ((2 / Fintype.card Digest) * (count : ENNReal)) := by
+    unfold prefixContactGame prefixIdealCostGame
+    apply QueryCap.scaled_expectation_bind_le
+    intro parameter hparameter
+    apply QueryCap.scaled_expectation_bind_le
+    intro ftsSecret _
+    apply QueryCap.scaled_expectation_bind_le
+    intro selections hselections
+    apply QueryCap.scaled_expectation_bind_le
+    intro other _
+    apply QueryCap.scaled_expectation_bind_le
+    intro auxiliary hauxiliary
+    let words := referenceFamilyWords selections dummy
+    let segment := OtsPrefix.atAddress parameter words address
+    let inputs := canonicalGraphGameInputs adversary
+    let hencoding := canonicalEncodingInputs_subset_gameInputs adversary parameter
+    let hgraph := canonicalGraphInputs_subset_gameInputs adversary parameter
+    let computation := fun endpoint => segment.seedGame inputs hencoding hgraph auxiliary other.val ftsSecret words endpoint adversary
+    let cost := fun result : Bool × SigningBoundaryTrace => result.2.hashCalls
+    have hcharge : ∀ endpoint result, result ∈ support (QueryCap.counted PartialChainEndpoint.IsPrefixQuery (computation endpoint)) →
+        result.2 ≤ cost result.1 :=
+      fun endpoint result hresult => segment.seedGame_counted_le inputs hencoding hgraph auxiliary other.val
+        ftsSecret words endpoint adversary result hresult
+    have hreal : ∀ result ∈ (PartialChainEndpoint.realRun (fun _ => OtsPrefix.uniformImpl) computation (fun _ _ => none)).support,
+        cost result.2.1 ≤ q :=
+      prefixObservedRun_hashCalls_le parameter (probComp_mem_of_evalDist _ parameter hparameter) ftsSecret
+        address.1 address.2.1 address.2.2.1 address.2.2.2 dummy adversary selections (pmf_mem_of_evalDist _ selections hselections)
+        q hbound other auxiliary (pmf_mem_of_evalDist _ auxiliary hauxiliary)
+    have hcontact := PartialChainEndpoint.realRun_contact_le_cap_cost (fun _ => OtsPrefix.uniformImpl) computation cost q hcharge hreal hsmall
+    simp only [one_mul, tsum_probOutput_bind_mul, tsum_probOutput_pure_mul]
+    simpa only [PMF.evalDist_eq, SPMF.probOutput_liftM, PMF.probOutput_eq_apply, decide_eq_true_eq,
+      probEvent_eq_tsum_ite, mul_ite, mul_one, mul_zero,
+      mul_left_comm _ (2 / (Fintype.card Digest : ENNReal)), ENNReal.tsum_mul_left] using hcontact
+  simpa only [one_mul, mul_ite, mul_one, mul_zero, tsum_ite_eq,
+    mul_left_comm _ (2 / (Fintype.card Digest : ENNReal)), ENNReal.tsum_mul_left] using h
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixFrontier.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixFrontier.lean
new file mode 100644
index 000000000..c7d4c3ef3
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixFrontier.lean
@@ -0,0 +1,101 @@
+import SphincsSecurity.Proof.Ots.OtsPrefixOracle
+import SphincsSecurity.Proof.Ots.CanonicalEncodingSampling
+import SphincsSecurity.Proof.Hypertree.FrontierOracleCongruence
+namespace SphincsSecurity.Concrete.OtsPrefix
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalFrontierValues frontierLayerMessage
+
+def SameChain (segment : OtsPrefix) (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (chainIdx : ChainIndex) : Prop :=
+  lay = segment.lay ∧ tree = segment.tree ∧ leaf = segment.leaf ∧ chainIdx = segment.chainIdx
+
+instance (segment : OtsPrefix) (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (chainIdx : ChainIndex) :
+    Decidable (segment.SameChain lay tree leaf chainIdx) := inferInstanceAs (Decidable (_ ∧ _ ∧ _ ∧ _))
+
+def replaceChain (segment : OtsPrefix) (values : OtsFrontierValues) (value : Digest) : OtsFrontierValues :=
+  fun lay tree leaf chainIdx => if segment.SameChain lay tree leaf chainIdx then value else values lay tree leaf chainIdx
+
+theorem parse_other_chain (segment : OtsPrefix) (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (chainIdx : ChainIndex)
+    (hother : ¬segment.SameChain lay tree leaf chainIdx) (step : ChainStep) (value : Digest) :
+    segment.parse (tweakableHashInput segment.parameter (.chain lay tree leaf chainIdx step) (digestBytes value)) = none := by
+  cases hparse : segment.parse (tweakableHashInput segment.parameter (.chain lay tree leaf chainIdx step) (digestBytes value)) with
+  | none => rfl
+  | some query =>
+      have hinput := (segment.parse_some_iff _ query).mp hparse
+      have hparts := tweakableHashInput_injective segment.parameter (by trivial) (by trivial) hinput
+      have hchains : lay = segment.lay ∧ tree = segment.tree ∧ leaf = segment.leaf ∧ chainIdx = segment.chainIdx ∧
+          step = segment.step query.1 := by
+        simpa only [input, HashDomain.chain.injEq] using hparts.1
+      exact False.elim (hother ⟨hchains.1, hchains.2.1, hchains.2.2.1, hchains.2.2.2.1⟩)
+
+theorem answer_other_chain (segment : OtsPrefix) (tables : Fin segment.digit.val → Digest → Digest)
+    (high : segment.Query → High) (outside : QueryImpl HashSpec Id)
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (chainIdx : ChainIndex)
+    (hother : ¬segment.SameChain lay tree leaf chainIdx) (step : ChainStep) (value : Digest) :
+    segment.answer tables high outside (tweakableHashInput segment.parameter (.chain lay tree leaf chainIdx step) (digestBytes value)) =
+      outside (tweakableHashInput segment.parameter (.chain lay tree leaf chainIdx step) (digestBytes value)) := by
+  simp only [answer, segment.parse_other_chain lay tree leaf chainIdx hother step value]
+
+theorem lows_answer (segment : OtsPrefix) (tables : Fin segment.digit.val → Digest → Digest)
+    (high : segment.Query → High) (outside : QueryImpl HashSpec Id) :
+    segment.lows (segment.answer tables high outside) = tables := by
+  funext level value
+  rw [lows, answer_input, truncate_combine]
+
+noncomputable def frontierFromEndpoint (segment : OtsPrefix) (outside : QueryImpl HashSpec Id)
+    (secrets : OtsFrontierValues) (words : OtsReferenceWords) (endpoint : Digest) : OtsFrontierValues :=
+  segment.replaceChain (fun lay tree leaf chainIdx => evalWithAnswerFn outside
+    (chainWalk segment.parameter lay tree leaf chainIdx 0 (words lay tree leaf chainIdx).val
+      (secrets lay tree leaf chainIdx))) endpoint
+
+theorem frontierFromEndpoint_replaceSecret (segment : OtsPrefix) (outside : QueryImpl HashSpec Id)
+    (secrets : OtsFrontierValues) (words : OtsReferenceWords) (endpoint replacement : Digest) :
+    segment.frontierFromEndpoint outside (segment.replaceChain secrets replacement) words endpoint =
+      segment.frontierFromEndpoint outside secrets words endpoint := by
+  funext lay tree leaf chainIdx
+  by_cases h : segment.SameChain lay tree leaf chainIdx <;>
+    simp only [frontierFromEndpoint, replaceChain, h, ↓reduceIte]
+
+theorem canonicalFrontierValues_answer (segment : OtsPrefix) (tables : Fin segment.digit.val → Digest → Digest)
+    (high : segment.Query → High) (outside : QueryImpl HashSpec Id) (root : Digest)
+    (secrets : OtsFrontierValues) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (hword : words segment.lay segment.tree segment.leaf segment.chainIdx = segment.digit) :
+    canonicalFrontierValues ⟨segment.parameter, root, secrets, ftsSecret⟩ (segment.answer tables high outside) words =
+      segment.frontierFromEndpoint outside secrets words
+        (PartialChainEndpoint.evaluate tables (secrets segment.lay segment.tree segment.leaf segment.chainIdx)) := by
+  funext lay tree leaf chainIdx
+  rw [canonicalFrontierValues, frontierFromEndpoint, replaceChain]
+  by_cases h : segment.SameChain lay tree leaf chainIdx
+  · rw [if_pos h]
+    obtain ⟨rfl, rfl, rfl, rfl⟩ := h
+    rw [hword, ← segment.evaluate_lows, segment.lows_answer]
+  · rw [if_neg h]
+    apply eval_chainWalk_congr_tail
+    · have hdigit := (words lay tree leaf chainIdx).isLt
+      simp only [chainLength, winternitzBits] at hdigit ⊢
+      omega
+    · intro step _ value
+      exact congrArg truncateHash (segment.answer_other_chain tables high outside lay tree leaf chainIdx h step value)
+
+theorem graphMessage_answer (segment : OtsPrefix) (tables : Fin segment.digit.val → Digest → Digest)
+    (high : segment.Query → High) (outside : QueryImpl HashSpec Id) (root : Digest)
+    (secrets : OtsFrontierValues) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (hword : words segment.lay segment.tree segment.leaf segment.chainIdx = segment.digit)
+    (position : EncodingPosition) :
+    canonicalGraphMessage (canonicalGraphLabels segment.parameter secrets ftsSecret (segment.answer tables high outside)) position =
+      evalWithAnswerFn outside (frontierLayerMessage segment.parameter ftsSecret words
+        (segment.frontierFromEndpoint outside secrets words
+          (PartialChainEndpoint.evaluate tables (secrets segment.lay segment.tree segment.leaf segment.chainIdx)))
+        (referenceIndex position.lay position.tree position.leafIdx) position.lay) := by
+  let key : SecretKey := ⟨segment.parameter, root, secrets, ftsSecret⟩
+  have hfrontier : IsSigningFrontier key (segment.answer tables high outside) words
+      (segment.frontierFromEndpoint outside secrets words
+        (PartialChainEndpoint.evaluate tables (secrets segment.lay segment.tree segment.leaf segment.chainIdx))) := by
+    rw [← segment.canonicalFrontierValues_answer tables high outside root secrets ftsSecret words hword]
+    exact isSigningFrontier_canonical key _ words
+  rw [canonicalGraphMessage_eq key, ← eval_frontierLayerMessage key _ words _ hfrontier]
+  exact eval_frontierLayerMessage_eq_of_agree segment.parameter words _ outside
+    (segment.answer_agrees_outside words (by rw [hword]) tables high outside) ftsSecret _ _ _
+
+end SphincsSecurity.Concrete.OtsPrefix
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixIdealAllocation.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixIdealAllocation.lean
new file mode 100644
index 000000000..160b7be8b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixIdealAllocation.lean
@@ -0,0 +1,76 @@
+import SphincsSecurity.Proof.Chains.AdaptiveChainCapCost
+import SphincsSecurity.Proof.Ots.OtsPrefixAccounting
+import SphincsSecurity.Proof.Ots.OtsPrefixObservedBudget
+import SphincsSecurity.Proof.Ots.OtsPrefixObservedAllocation
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+noncomputable def prefixIdealCostGame (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords) (adversary : Adversary) (q : Nat) : SPMF Nat := do
+  let parameter ← 𝒟[sampleParameter]
+  let ftsSecret ← 𝒟[sampleFtsSecrets]
+  let selections ← 𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit]
+  let words := referenceFamilyWords selections dummy
+  let segment := OtsPrefix.atAddress parameter words address
+  let other ← 𝒟[PMF.uniformOfFintype segment.ErasedSecrets]
+  let auxiliary ← 𝒟[segment.referenceAuxSeedLaw inputs (hencoding parameter) (hgraph parameter) selections]
+  let result ← 𝒟[PartialChainEndpoint.idealRun (fun _ => OtsPrefix.uniformImpl)
+    (fun endpoint => QueryCap.run PartialChainEndpoint.IsPrefixQuery
+      (segment.seedGame inputs (hencoding parameter) (hgraph parameter) auxiliary other.val ftsSecret words endpoint adversary) q)
+    (fun _ _ => none)]
+  pure (QueryCap.spent q result.2.1)
+
+private theorem probComp_mem_of_evalDist {Result : Type} (computation : ProbComp Result) (result : Result)
+    (hresult : result ∈ support 𝒟[computation]) : result ∈ support computation :=
+  (mem_support_iff_of_evalDist_eq (mx := computation) (mx' := 𝒟[computation]) rfl result).mpr hresult
+
+private theorem pmf_mem_of_evalDist {Result : Type} (law : PMF Result) (result : Result)
+    (hresult : result ∈ support 𝒟[law]) : result ∈ law.support := by
+  change result ∈ (𝒟[law]).support at hresult
+  simpa only [PMF.evalDist_eq, SPMF.support_liftM] using hresult
+
+theorem prefixIdealCostGame_lower (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords)
+    (adversary : Adversary) (q : Nat) (hbound : HasHashQueryBound scheme adversary q) :
+    (1 - (q : ENNReal) / Fintype.card Digest) *
+        (∑' count, Pr[= count | prefixIdealCostGame (canonicalGraphGameInputs adversary)
+          (canonicalEncodingInputs_subset_gameInputs adversary) (canonicalGraphInputs_subset_gameInputs adversary)
+          address dummy adversary q] * (count : ENNReal)) ≤
+      ∑' result : PrefixCountedResult, Pr[= result | prefixCountedObservedGame (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary) (canonicalGraphInputs_subset_gameInputs adversary)
+        address dummy adversary] * (result.2.2.2 : ENNReal) := by
+  unfold prefixIdealCostGame prefixCountedObservedGame
+  apply QueryCap.scaled_expectation_bind_le
+  intro parameter hparameter
+  apply QueryCap.scaled_expectation_bind_le
+  intro ftsSecret _
+  apply QueryCap.scaled_expectation_bind_le
+  intro selections hselections
+  apply QueryCap.scaled_expectation_bind_le
+  intro other _
+  apply QueryCap.scaled_expectation_bind_le
+  intro auxiliary hauxiliary
+  let words := referenceFamilyWords selections dummy
+  let segment := OtsPrefix.atAddress parameter words address
+  let inputs := canonicalGraphGameInputs adversary
+  let hencoding := canonicalEncodingInputs_subset_gameInputs adversary parameter
+  let hgraph := canonicalGraphInputs_subset_gameInputs adversary parameter
+  let computation := fun endpoint => segment.seedGame inputs hencoding hgraph auxiliary other.val ftsSecret words endpoint adversary
+  let cost := fun result : Bool × SigningBoundaryTrace => result.2.hashCalls
+  have hcharge : ∀ endpoint result, result ∈ support (QueryCap.counted PartialChainEndpoint.IsPrefixQuery (computation endpoint)) →
+      result.2 ≤ cost result.1 :=
+    fun endpoint result hresult => segment.seedGame_counted_le inputs hencoding hgraph auxiliary other.val
+      ftsSecret words endpoint adversary result hresult
+  have hreal : ∀ result ∈ (PartialChainEndpoint.realRun (fun _ => OtsPrefix.uniformImpl) computation (fun _ _ => none)).support,
+      cost result.2.1 ≤ q :=
+    prefixObservedRun_hashCalls_le parameter (probComp_mem_of_evalDist _ parameter hparameter) ftsSecret
+      address.1 address.2.1 address.2.2.1 address.2.2.2 dummy adversary selections (pmf_mem_of_evalDist _ selections hselections)
+      q hbound other auxiliary (pmf_mem_of_evalDist _ auxiliary hauxiliary)
+  have h := PartialChainEndpoint.idealRun_cap_spent_lower (fun _ => OtsPrefix.uniformImpl) computation cost q hcharge hreal
+  simpa only [tsum_probOutput_bind_mul, tsum_probOutput_pure_mul, ← PMF.monad_map_eq_map,
+    evalDist_map, tsum_probOutput_map_mul, PMF.evalDist_eq, SPMF.probOutput_liftM, PMF.probOutput_eq_apply] using h
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixInstrumentedSeed.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixInstrumentedSeed.lean
new file mode 100644
index 000000000..afbe42aa7
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixInstrumentedSeed.lean
@@ -0,0 +1,56 @@
+import SphincsSecurity.Proof.Reference.ReferenceInstrumentedGame
+import SphincsSecurity.Proof.Ots.OtsPrefixSeedGame
+namespace SphincsSecurity.Concrete.OtsPrefix
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+variable {Result : Type} (segment : OtsPrefix) (observer : FrontierObserver Result) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs) (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+
+noncomputable def instrumentedSeedGame (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph)
+    (secrets : OtsFrontierValues) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (endpoint : Digest) (adversary : Adversary) : OracleComp segment.World Result :=
+  let outside := segment.seedOracle inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint
+  let frontier := segment.seedFrontier inputs hencoding hgraph auxiliary secrets words endpoint
+  simulateQ (segment.worldImpl auxiliary.high outside) (observer segment.parameter words frontier
+    (CausalFrontierProgram.game segment.parameter outside ftsSecret words frontier adversary))
+
+theorem instrumentedSeedGame_replaceSecret (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph)
+    (secrets : OtsFrontierValues) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (endpoint replacement : Digest) (adversary : Adversary) :
+    segment.instrumentedSeedGame observer inputs hencoding hgraph auxiliary (segment.replaceChain secrets replacement)
+      ftsSecret words endpoint adversary =
+    segment.instrumentedSeedGame observer inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary := by
+  simp only [instrumentedSeedGame, seedOracle_replaceSecret, seedFrontier_replaceSecret]
+
+theorem fixedImpl_world_program (tables : Fin segment.digit.val → Digest → Digest)
+    (high : segment.Query → High) (outside : QueryImpl HashSpec Id) (computation : OracleComp OracleWorld Result) :
+    simulateQ (segment.fixedImpl tables) (simulateQ (segment.worldImpl high outside) computation) =
+      simulateQ (fixedHashWorld (segment.answer tables high outside)) computation := by
+  rw [← QueryImpl.simulateQ_compose]
+  congr 1
+  funext input
+  exact segment.fixedImpl_worldImpl tables high outside input
+
+theorem referenceSeedGame_instrumented (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph)
+    (root : Digest) (secrets : OtsFrontierValues) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords)
+    (hword : referenceFamilyWords selections dummy segment.lay segment.tree segment.leaf segment.chainIdx = segment.digit)
+    (tables : Fin segment.digit.val → Digest → Digest) (adversary : Adversary) :
+    let key : SecretKey := ⟨segment.parameter, root, secrets, ftsSecret⟩
+    let oracle := finiteHashAnswer ∅ inputs (referenceFamilySeedTable key inputs hencoding
+      (segment.referenceSeed inputs hencoding hgraph selections tables auxiliary))
+    referenceInstrumentedRest observer key oracle (canonicalGraphLabels segment.parameter secrets ftsSecret oracle) selections dummy adversary =
+      simulateQ (segment.fixedImpl tables) (segment.instrumentedSeedGame observer inputs hencoding hgraph auxiliary
+        (segment.replaceChain secrets 0) ftsSecret (referenceFamilyWords selections dummy)
+        (PartialChainEndpoint.evaluate tables (secrets segment.lay segment.tree segment.leaf segment.chainIdx)) adversary) := by
+  dsimp only
+  rw [instrumentedSeedGame_replaceSecret, instrumentedSeedGame, segment.fixedImpl_world_program]
+  rw [referenceInstrumentedRest,
+    segment.referenceSeedFrontier_eq inputs hencoding hgraph auxiliary root secrets ftsSecret selections _ hword tables,
+    segment.referenceSeedOracle_eq inputs hencoding hgraph auxiliary root secrets ftsSecret selections _ hword tables]
+  rw [segment.program_mask_answer tables auxiliary.high _ ftsSecret (referenceFamilyWords selections dummy) (by rw [hword])]
+
+end SphincsSecurity.Concrete.OtsPrefix
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixInstrumentedSource.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixInstrumentedSource.lean
new file mode 100644
index 000000000..1210694fa
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixInstrumentedSource.lean
@@ -0,0 +1,120 @@
+import SphincsSecurity.Proof.Ots.OtsPrefixInstrumentedSeed
+import SphincsSecurity.Proof.Ots.OtsPrefixObservedSource
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+variable {Result : Type} (observer : FrontierObserver Result)
+
+noncomputable def prefixInstrumentedSeedRest (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (hgraph : canonicalGraphInputs key.parameter ⊆ inputs)
+    (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords) (adversary : Adversary) : SPMF (InstrumentedResult Result) := do
+  let selections ← 𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit]
+  let words := referenceFamilyWords selections dummy
+  let segment := OtsPrefix.atAddress key.parameter words address
+  let tables ← 𝒟[PMF.uniformOfFintype (Fin segment.digit.val → Digest → Digest)]
+  let auxiliary ← 𝒟[segment.referenceAuxSeedLaw inputs hencoding hgraph selections]
+  let result ← 𝒟[simulateQ (segment.fixedImpl tables)
+    (segment.instrumentedSeedGame observer inputs hencoding hgraph auxiliary (segment.replaceChain key.otsSecret 0) key.ftsSecret words
+      (PartialChainEndpoint.evaluate tables (key.otsSecret address.1 address.2.1 address.2.2.1 address.2.2.2)) adversary)]
+  pure (key.parameter, selections, result)
+
+theorem prefixInstrumentedSeedRest_eq (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (hgraph : canonicalGraphInputs key.parameter ⊆ inputs)
+    (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    prefixInstrumentedSeedRest observer key inputs hencoding hgraph address dummy adversary = (do
+      let reference ← 𝒟[referenceFamilyOracleSample key inputs hencoding]
+      let oracle := finiteHashAnswer ∅ inputs reference.2
+      let result ← 𝒟[referenceInstrumentedRest observer key oracle
+        (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret oracle) reference.1 dummy adversary]
+      pure (key.parameter, reference.1, result)) := by
+  rw [referenceFamilyOracleSample_eq_prefixSeed key inputs hencoding hgraph address.1 address.2.1 address.2.2.1 address.2.2.2
+    (fun selections => referenceFamilyWords selections dummy address.1 address.2.1 address.2.2.1 address.2.2.2)]
+  simp only [← PMF.monad_bind_eq_bind, ← PMF.monad_map_eq_map, evalDist_bind, evalDist_map, bind_assoc, bind_map_left]
+  unfold prefixInstrumentedSeedRest
+  apply congrArg (𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit] >>= ·)
+  funext selections
+  let words := referenceFamilyWords selections dummy
+  let segment := OtsPrefix.atAddress key.parameter words address
+  apply congrArg (𝒟[PMF.uniformOfFintype (Fin segment.digit.val → Digest → Digest)] >>= ·)
+  funext tables
+  apply congrArg (𝒟[segment.referenceAuxSeedLaw inputs hencoding hgraph selections] >>= ·)
+  funext auxiliary
+  rw [segment.referenceSeedGame_instrumented observer inputs hencoding hgraph auxiliary key.root key.otsSecret key.ftsSecret
+    selections dummy rfl tables adversary]
+
+noncomputable def prefixInstrumentedSourceGame (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords) (adversary : Adversary) : SPMF (InstrumentedResult Result) := do
+  let parameter ← 𝒟[sampleParameter]
+  let otsSecret ← 𝒟[sampleOtsSecrets]
+  let ftsSecret ← 𝒟[sampleFtsSecrets]
+  prefixInstrumentedSeedRest observer ⟨parameter, 0, otsSecret, ftsSecret⟩ inputs (hencoding parameter) (hgraph parameter) address dummy adversary
+
+theorem prefixInstrumentedSourceGame_eq (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    prefixInstrumentedSourceGame observer inputs hencoding hgraph address dummy adversary =
+      referenceInstrumentedGame observer inputs hencoding dummy adversary := by
+  simp only [prefixInstrumentedSourceGame, referenceInstrumentedGame, prefixInstrumentedSeedRest_eq]
+
+noncomputable def prefixInstrumentedObservedGame (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords) (adversary : Adversary) : SPMF (InstrumentedResult Result) := do
+  let parameter ← 𝒟[sampleParameter]
+  let ftsSecret ← 𝒟[sampleFtsSecrets]
+  let selections ← 𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit]
+  let words := referenceFamilyWords selections dummy
+  let segment := OtsPrefix.atAddress parameter words address
+  let other ← 𝒟[PMF.uniformOfFintype segment.ErasedSecrets]
+  let auxiliary ← 𝒟[segment.referenceAuxSeedLaw inputs (hencoding parameter) (hgraph parameter) selections]
+  let result ← 𝒟[(PartialChainEndpoint.realRun (fun _ => OtsPrefix.uniformImpl)
+    (fun endpoint => segment.instrumentedSeedGame observer inputs (hencoding parameter) (hgraph parameter)
+      auxiliary other.val ftsSecret words endpoint adversary) (fun _ _ => none)).map (fun result => result.2.1)]
+  pure (parameter, selections, result)
+
+theorem prefixInstrumentedObservedGame_eq (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    prefixInstrumentedObservedGame observer inputs hencoding hgraph address dummy adversary =
+      prefixInstrumentedSourceGame observer inputs hencoding hgraph address dummy adversary := by
+  symm
+  unfold prefixInstrumentedSourceGame prefixInstrumentedSeedRest prefixInstrumentedObservedGame
+  dsimp only
+  apply congrArg (𝒟[sampleParameter] >>= ·)
+  funext parameter
+  rw [swap_samples 𝒟[sampleOtsSecrets] 𝒟[sampleFtsSecrets]]
+  apply congrArg (𝒟[sampleFtsSecrets] >>= ·)
+  funext ftsSecret
+  rw [swap_samples 𝒟[sampleOtsSecrets] 𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit]]
+  apply congrArg (𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit] >>= ·)
+  funext selections
+  let words := referenceFamilyWords selections dummy
+  let segment := OtsPrefix.atAddress parameter words address
+  rw [segment.sampleOtsSecrets_eq_split]
+  simp only [bind_assoc, pure_bind, OtsPrefix.instrumentedSeedGame_replaceSecret]
+  apply congrArg (𝒟[PMF.uniformOfFintype segment.ErasedSecrets] >>= ·)
+  funext other
+  rw [reverse_three_samples 𝒟[PMF.uniformOfFintype Digest]
+    𝒟[PMF.uniformOfFintype (Fin segment.digit.val → Digest → Digest)]
+    𝒟[segment.referenceAuxSeedLaw inputs (hencoding parameter) (hgraph parameter) selections]]
+  apply congrArg (𝒟[segment.referenceAuxSeedLaw inputs (hencoding parameter) (hgraph parameter) selections] >>= ·)
+  funext auxiliary
+  rw [segment.realRun_empty_forget]
+  have hselected (secret : Digest) :
+      segment.replaceChain other.val secret address.1 address.2.1 address.2.2.1 address.2.2.2 = secret :=
+    segment.replaceChain_self other.val secret
+  simp only [bind_assoc, hselected]
+  dsimp only [segment, words]
+  simp only [OtsPrefix.instrumentedSeedGame_replaceSecret]
+
+theorem prefixInstrumentedObservedGame_original (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    prefixInstrumentedObservedGame observer inputs hencoding hgraph address dummy adversary =
+      referenceInstrumentedGame observer inputs hencoding dummy adversary := by
+  rw [prefixInstrumentedObservedGame_eq, prefixInstrumentedSourceGame_eq]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixInstrumentedVisible.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixInstrumentedVisible.lean
new file mode 100644
index 000000000..36c177ae1
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixInstrumentedVisible.lean
@@ -0,0 +1,39 @@
+import SphincsSecurity.Proof.Ots.OtsPrefixInstrumentedSeed
+import SphincsSecurity.Proof.Ots.OtsPrefixVisible
+namespace SphincsSecurity.Concrete.OtsPrefix
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+variable {Result : Type} (segment : OtsPrefix) (observer : FrontierObserver Result) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs) (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+  (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph) (secrets : OtsFrontierValues)
+  (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (adversary : Adversary)
+
+noncomputable def visibleInstrumentedSeedGame (endpoint : Digest) : OracleComp segment.VisibleWorld Result :=
+  let outside := segment.seedOracle inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint
+  let frontier := segment.seedFrontier inputs hencoding hgraph auxiliary secrets words endpoint
+  simulateQ (segment.visibleWorldImpl auxiliary.high) (observer segment.parameter words frontier
+    (CausalFrontierProgram.game segment.parameter outside ftsSecret words frontier adversary))
+
+theorem erase_visibleInstrumentedSeedGame (endpoint : Digest) :
+    simulateQ (PartialChainEndpoint.eraseAux (segment.seedOracle inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint))
+      (segment.visibleInstrumentedSeedGame observer inputs hencoding hgraph auxiliary secrets ftsSecret words adversary endpoint) =
+    segment.instrumentedSeedGame observer inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary := by
+  rw [visibleInstrumentedSeedGame, ← QueryImpl.simulateQ_compose, erase_visibleWorldImpl]
+  rfl
+
+theorem visibleInstrumentedSeedGame_real :
+    PartialChainEndpoint.realRun (fun endpoint => PartialChainEndpoint.extendAux uniformImpl
+      (segment.seedOracle inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint))
+      (segment.visibleInstrumentedSeedGame observer inputs hencoding hgraph auxiliary secrets ftsSecret words adversary) (fun _ _ => none) =
+    PartialChainEndpoint.realRun (fun _ => uniformImpl)
+      (fun endpoint => segment.instrumentedSeedGame observer inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+      (fun _ _ => none) := by
+  simpa only [erase_visibleInstrumentedSeedGame] using
+    (PartialChainEndpoint.realRun_eraseAux (fun _ => uniformImpl)
+      (segment.seedOracle inputs hencoding hgraph auxiliary secrets ftsSecret words)
+      (segment.visibleInstrumentedSeedGame observer inputs hencoding hgraph auxiliary secrets ftsSecret words adversary) (fun _ _ => none)).symm
+
+end SphincsSecurity.Concrete.OtsPrefix
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixObservedAllocation.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixObservedAllocation.lean
new file mode 100644
index 000000000..2503a4c66
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixObservedAllocation.lean
@@ -0,0 +1,67 @@
+import SphincsSecurity.Proof.Ots.OtsPrefixSeedAllocation
+import SphincsSecurity.Proof.Ots.OtsPrefixObservedSource
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+noncomputable def prefixCountedObservedGame (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords) (adversary : Adversary) : SPMF PrefixCountedResult := do
+  let parameter ← 𝒟[sampleParameter]
+  let ftsSecret ← 𝒟[sampleFtsSecrets]
+  let selections ← 𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit]
+  let words := referenceFamilyWords selections dummy
+  let segment := OtsPrefix.atAddress parameter words address
+  let other ← 𝒟[PMF.uniformOfFintype segment.ErasedSecrets]
+  let auxiliary ← 𝒟[segment.referenceAuxSeedLaw inputs (hencoding parameter) (hgraph parameter) selections]
+  let result ← 𝒟[(PartialChainEndpoint.realRun (fun _ => OtsPrefix.uniformImpl)
+    (fun endpoint => QueryCap.counted PartialChainEndpoint.IsPrefixQuery
+      (segment.seedGame inputs (hencoding parameter) (hgraph parameter) auxiliary other.val ftsSecret words endpoint adversary))
+    (fun _ _ => none)).map (fun result => result.2.1)]
+  pure (parameter, selections, result)
+
+theorem prefixCountedObservedGame_eq (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    prefixCountedObservedGame inputs hencoding hgraph address dummy adversary =
+      prefixCountedSourceGame inputs hencoding hgraph address dummy adversary := by
+  symm
+  unfold prefixCountedSourceGame prefixCountedSeedRest prefixCountedObservedGame
+  dsimp only
+  apply congrArg (𝒟[sampleParameter] >>= ·)
+  funext parameter
+  rw [swap_samples 𝒟[sampleOtsSecrets] 𝒟[sampleFtsSecrets]]
+  apply congrArg (𝒟[sampleFtsSecrets] >>= ·)
+  funext ftsSecret
+  rw [swap_samples 𝒟[sampleOtsSecrets] 𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit]]
+  apply congrArg (𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit] >>= ·)
+  funext selections
+  let words := referenceFamilyWords selections dummy
+  let segment := OtsPrefix.atAddress parameter words address
+  rw [segment.sampleOtsSecrets_eq_split]
+  simp only [bind_assoc, pure_bind, OtsPrefix.seedGame_replaceSecret]
+  apply congrArg (𝒟[PMF.uniformOfFintype segment.ErasedSecrets] >>= ·)
+  funext other
+  rw [reverse_three_samples 𝒟[PMF.uniformOfFintype Digest]
+    𝒟[PMF.uniformOfFintype (Fin segment.digit.val → Digest → Digest)]
+    𝒟[segment.referenceAuxSeedLaw inputs (hencoding parameter) (hgraph parameter) selections]]
+  apply congrArg (𝒟[segment.referenceAuxSeedLaw inputs (hencoding parameter) (hgraph parameter) selections] >>= ·)
+  funext auxiliary
+  rw [segment.realRun_empty_forget]
+  have hselected (secret : Digest) :
+      segment.replaceChain other.val secret address.1 address.2.1 address.2.2.1 address.2.2.2 = secret :=
+    segment.replaceChain_self other.val secret
+  simp only [bind_assoc, hselected]
+  dsimp only [segment, words]
+  simp only [OtsPrefix.seedGame_replaceSecret]
+
+theorem prefixCountedObservedGame_original (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    prefixCountedObservedGame inputs hencoding hgraph address dummy adversary =
+      ReferenceRecordedResult.prefixCounted address dummy <$> referenceRecordedGame inputs hencoding dummy adversary := by
+  rw [prefixCountedObservedGame_eq, prefixCountedSourceGame_eq]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixObservedBudget.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixObservedBudget.lean
new file mode 100644
index 000000000..32fb9d6f4
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixObservedBudget.lean
@@ -0,0 +1,55 @@
+import SphincsSecurity.Proof.Ots.OtsPrefixObservedSource
+import SphincsSecurity.Proof.Chains.AdaptiveChainSupport
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+private theorem pmf_mem_evalDist {Result : Type} (law : PMF Result) (result : Result) (h : result ∈ law.support) :
+    result ∈ support 𝒟[law] := by
+  change result ∈ (𝒟[law]).support
+  simpa only [PMF.evalDist_eq, SPMF.support_liftM] using h
+
+private theorem probComp_mem_evalDist {Result : Type} (law : ProbComp Result) (result : Result)
+    (h : result ∈ support law) : result ∈ support 𝒟[law] :=
+  (mem_support_iff_of_evalDist_eq (mx := law) (mx' := 𝒟[law]) rfl result).mp h
+
+private theorem ftsSecret_mem_evalDist (ftsSecret : Index → FtsTree → FtsLeaf → Digest) :
+    ftsSecret ∈ support 𝒟[sampleFtsSecrets] := by
+  apply probComp_mem_evalDist
+  unfold sampleFtsSecrets
+  change ftsSecret ∈ support (@SampleableType.selectElem (Index → FtsTree → FtsLeaf → Digest) ftsSecretsSampleableType)
+  exact ftsSecretsSampleableType.mem_support_selectElem ftsSecret
+
+theorem prefixObservedRun_hashCalls_le (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (chainIdx : ChainIndex)
+    (dummy : OtsReferenceWords) (adversary : Adversary) (selections : ReferenceFamily)
+    (hselections : selections ∈ (FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit).support)
+    (q : Nat) (hbound : HasHashQueryBound scheme adversary q) :
+    let words := referenceFamilyWords selections dummy
+    let segment : OtsPrefix := ⟨parameter, lay, tree, leaf, chainIdx, words lay tree leaf chainIdx⟩
+    let inputs := canonicalGraphGameInputs adversary
+    let hencoding := canonicalEncodingInputs_subset_gameInputs adversary parameter
+    let hgraph := canonicalGraphInputs_subset_gameInputs adversary parameter
+    ∀ (other : segment.ErasedSecrets) (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph),
+      auxiliary ∈ (segment.referenceAuxSeedLaw inputs hencoding hgraph selections).support →
+      ∀ result ∈ (segment.seedObservedRun inputs hencoding hgraph auxiliary other.val ftsSecret words adversary).support,
+        result.2.1.2.hashCalls ≤ q := by
+  dsimp only
+  intro other auxiliary hauxiliary result hresult
+  apply prefixObservedSourceGame_hashCalls_le lay tree leaf chainIdx dummy adversary q hbound (selections, result.2.1)
+  unfold prefixObservedSourceGame
+  refine (mem_support_bind_iff _ _ _).mpr ⟨parameter, probComp_mem_evalDist _ _ hparameter, ?_⟩
+  refine (mem_support_bind_iff _ _ _).mpr ⟨ftsSecret, ftsSecret_mem_evalDist ftsSecret, ?_⟩
+  refine (mem_support_bind_iff _ _ _).mpr ⟨selections, pmf_mem_evalDist _ _ hselections, ?_⟩
+  refine (mem_support_bind_iff _ _ _).mpr ⟨other, pmf_mem_evalDist _ _ (PMF.mem_support_uniformOfFintype other), ?_⟩
+  refine (mem_support_bind_iff _ _ _).mpr ⟨auxiliary, pmf_mem_evalDist _ _ hauxiliary, ?_⟩
+  refine (mem_support_bind_iff _ _ _).mpr ⟨result.2.1, ?_, ?_⟩
+  · apply pmf_mem_evalDist
+    rw [PMF.mem_support_map_iff]
+    exact ⟨result, hresult, rfl⟩
+  · exact (mem_support_pure_iff _ _).mpr rfl
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixObservedRun.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixObservedRun.lean
new file mode 100644
index 000000000..1e6b4f881
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixObservedRun.lean
@@ -0,0 +1,52 @@
+import SphincsSecurity.Proof.Chains.AdaptiveChainErasure
+import SphincsSecurity.Proof.Ots.OtsPrefixSeedGame
+namespace SphincsSecurity.Concrete.OtsPrefix
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def uniformImpl : QueryImpl unifSpec PMF :=
+  fun input => PMF.uniformOfFintype (Fin (input + 1))
+
+theorem fixedImpl_evalDist (segment : OtsPrefix) (tables : Fin segment.digit.val → Digest → Digest)
+    {Result : Type} (computation : OracleComp segment.World Result) :
+    𝒟[simulateQ (PartialChainEndpoint.fixedImpl uniformImpl tables) computation] =
+      𝒟[simulateQ (segment.fixedImpl tables) computation] := by
+  induction computation using OracleComp.inductionOn with
+  | pure result => simp only [simulateQ_pure, evalDist_pure]
+  | query_bind input next ih =>
+      simp only [simulateQ_bind, simulateQ_spec_query, evalDist_bind, ih]
+      cases input with
+      | inl input =>
+          simp only [PartialChainEndpoint.fixedImpl, fixedImpl, QueryImpl.add_apply_inl,
+            uniformImpl]
+          change (𝒟[PMF.uniformOfFintype (Fin (input + 1))] >>= fun answer =>
+            𝒟[simulateQ (segment.fixedImpl tables) (next answer)]) =
+            (𝒟[(liftM (unifSpec.query input) : ProbComp (Fin (input + 1)))] >>= fun answer =>
+              𝒟[simulateQ (segment.fixedImpl tables) (next answer)])
+          rw [evalDist_query]
+      | inr query =>
+          simp only [PartialChainEndpoint.fixedImpl, fixedImpl, QueryImpl.add_apply_inr,
+            ← PMF.monad_pure_eq_pure, evalDist_pure]
+
+theorem realRun_empty_forget (segment : OtsPrefix) {Result : Type}
+    (computation : Digest → OracleComp segment.World Result) :
+    𝒟[(PartialChainEndpoint.realRun (fun _ => uniformImpl) computation (fun _ _ => none)).map
+      (fun result => result.2.1)] = (do
+        let tables ← 𝒟[PMF.uniformOfFintype (Fin segment.digit.val → Digest → Digest)]
+        let secret ← 𝒟[PMF.uniformOfFintype Digest]
+        𝒟[simulateQ (segment.fixedImpl tables) (computation (PartialChainEndpoint.evaluate tables secret))] : SPMF Result) := by
+  rw [PartialChainEndpoint.realRun_empty_forget]
+  simp only [← PMF.monad_bind_eq_bind, evalDist_bind, segment.fixedImpl_evalDist]
+
+noncomputable def seedObservedRun (segment : OtsPrefix) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs)
+    (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+    (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph) (secrets : OtsFrontierValues)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (adversary : Adversary) :
+    PMF (Digest × ((Bool × SigningBoundaryTrace) × (Fin segment.digit.val → Digest → Option Digest))) :=
+  PartialChainEndpoint.realRun (fun _ => uniformImpl)
+    (fun endpoint => segment.seedGame inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+    (fun _ _ => none)
+
+end SphincsSecurity.Concrete.OtsPrefix
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixObservedSource.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixObservedSource.lean
new file mode 100644
index 000000000..0d46d4bc1
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixObservedSource.lean
@@ -0,0 +1,96 @@
+import SphincsSecurity.Proof.Ots.OtsPrefixSourceGame
+import SphincsSecurity.Proof.Ots.OtsPrefixSecretSampling
+import SphincsSecurity.Proof.Ots.OtsPrefixObservedRun
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+theorem swap_samples {A B Result : Type} (first : SPMF A) (second : SPMF B)
+    (next : A → B → SPMF Result) :
+    (do let a ← first; let b ← second; next a b) = (do let b ← second; let a ← first; next a b) := by
+  apply SPMF.ext
+  intro result
+  change Pr[= result | first >>= fun a => second >>= fun b => next a b] =
+    Pr[= result | second >>= fun b => first >>= fun a => next a b]
+  simp only [probOutput_bind_eq_tsum, ← ENNReal.tsum_mul_left]
+  rw [ENNReal.tsum_comm]
+  apply tsum_congr
+  intro b
+  apply tsum_congr
+  intro a
+  ring
+
+theorem reverse_three_samples {A B C Result : Type} (first : SPMF A) (second : SPMF B) (third : SPMF C)
+    (next : A → B → C → SPMF Result) :
+    (do let a ← first; let b ← second; let c ← third; next a b c) =
+      (do let c ← third; let b ← second; let a ← first; next a b c) := by
+  rw [swap_samples first second]
+  simp_rw [swap_samples first third]
+  rw [swap_samples second third]
+
+noncomputable def prefixObservedSourceGame (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (chainIdx : ChainIndex)
+    (dummy : OtsReferenceWords) (adversary : Adversary) : SPMF (ReferenceFamily × (Bool × SigningBoundaryTrace)) := do
+  let parameter ← 𝒟[sampleParameter]
+  let ftsSecret ← 𝒟[sampleFtsSecrets]
+  let selections ← 𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit]
+  let words := referenceFamilyWords selections dummy
+  let segment : OtsPrefix := ⟨parameter, lay, tree, leaf, chainIdx, words lay tree leaf chainIdx⟩
+  let other ← 𝒟[PMF.uniformOfFintype segment.ErasedSecrets]
+  let auxiliary ← 𝒟[segment.referenceAuxSeedLaw inputs (hencoding parameter) (hgraph parameter) selections]
+  let result ← 𝒟[(segment.seedObservedRun inputs (hencoding parameter) (hgraph parameter)
+    auxiliary other.val ftsSecret words adversary).map (fun result => result.2.1)]
+  pure (selections, result)
+
+theorem prefixObservedSourceGame_eq (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (chainIdx : ChainIndex)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    prefixObservedSourceGame inputs hencoding hgraph lay tree leaf chainIdx dummy adversary =
+      prefixSourceGame inputs hencoding hgraph lay tree leaf chainIdx dummy adversary := by
+  symm
+  unfold prefixSourceGame prefixSeedRest prefixObservedSourceGame
+  dsimp only
+  apply congrArg (𝒟[sampleParameter] >>= ·)
+  funext parameter
+  rw [swap_samples 𝒟[sampleOtsSecrets] 𝒟[sampleFtsSecrets]]
+  apply congrArg (𝒟[sampleFtsSecrets] >>= ·)
+  funext ftsSecret
+  rw [swap_samples 𝒟[sampleOtsSecrets]
+    𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit]]
+  apply congrArg (𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit] >>= ·)
+  funext selections
+  let words := referenceFamilyWords selections dummy
+  let segment : OtsPrefix := ⟨parameter, lay, tree, leaf, chainIdx, words lay tree leaf chainIdx⟩
+  rw [segment.sampleOtsSecrets_eq_split]
+  simp only [bind_assoc, pure_bind, OtsPrefix.seedGame_replaceSecret]
+  apply congrArg (𝒟[PMF.uniformOfFintype segment.ErasedSecrets] >>= ·)
+  funext other
+  rw [reverse_three_samples 𝒟[PMF.uniformOfFintype Digest]
+    𝒟[PMF.uniformOfFintype (Fin segment.digit.val → Digest → Digest)]
+    𝒟[segment.referenceAuxSeedLaw inputs (hencoding parameter) (hgraph parameter) selections]]
+  apply congrArg (𝒟[segment.referenceAuxSeedLaw inputs (hencoding parameter) (hgraph parameter) selections] >>= ·)
+  funext auxiliary
+  rw [OtsPrefix.seedObservedRun, segment.realRun_empty_forget]
+  have hselected (secret : Digest) : segment.replaceChain other.val secret lay tree leaf chainIdx = secret :=
+    segment.replaceChain_self other.val secret
+  simp only [bind_assoc, hselected]
+  dsimp only [segment, words]
+  simp only [OtsPrefix.seedGame_replaceSecret]
+
+theorem prefixObservedSourceGame_hashCalls_le (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (chainIdx : ChainIndex)
+    (dummy : OtsReferenceWords) (adversary : Adversary) (q : Nat) (hbound : HasHashQueryBound scheme adversary q)
+    (result : ReferenceFamily × (Bool × SigningBoundaryTrace))
+    (hresult : result ∈ support
+      (prefixObservedSourceGame (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary)
+        (canonicalGraphInputs_subset_gameInputs adversary) lay tree leaf chainIdx dummy adversary)) :
+    result.2.2.hashCalls ≤ q := by
+  rw [prefixObservedSourceGame_eq] at hresult
+  exact prefixSourceGame_hashCalls_le lay tree leaf chainIdx dummy adversary q hbound result hresult
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixOracle.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixOracle.lean
new file mode 100644
index 000000000..a6976257e
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixOracle.lean
@@ -0,0 +1,142 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.FrontierOracleMask
+import SphincsSecurity.Proof.Ots.OtsEndpointLikelihood
+import SphincsSecurity.Proof.Ots.SecretProbe
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+structure OtsPrefix where
+  parameter : PublicParameter
+  lay : Layer
+  tree : TreeIndex
+  leaf : LeafIndex
+  chainIdx : ChainIndex
+  digit : Digit
+
+namespace OtsPrefix
+
+abbrev Query (segment : OtsPrefix) := Fin segment.digit.val × Digest
+abbrev High := BitVec (hashOutputBits - digestBits)
+
+def step (segment : OtsPrefix) (index : Fin segment.digit.val) : ChainStep :=
+  ⟨index.val, by have := index.isLt; have := segment.digit.isLt; omega⟩
+
+def input (segment : OtsPrefix) (query : segment.Query) : HashInput :=
+  tweakableHashInput segment.parameter (.chain segment.lay segment.tree segment.leaf segment.chainIdx (segment.step query.1))
+    (digestBytes query.2)
+
+theorem input_injective (segment : OtsPrefix) : Function.Injective segment.input := by
+  intro left right heq
+  have hparts := tweakableHashInput_injective segment.parameter (by trivial) (by trivial) heq
+  have hstep : segment.step left.1 = segment.step right.1 := by
+    simpa only [HashDomain.chain.injEq, true_and] using hparts.1
+  have hindex : left.1.val = right.1.val := congrArg (fun position : ChainStep => position.val) hstep
+  exact Prod.ext (Fin.ext hindex) (digestBytes_injective hparts.2)
+
+noncomputable def parse (segment : OtsPrefix) (bytes : HashInput) : Option segment.Query :=
+  if h : ∃ query, segment.input query = bytes then some h.choose else none
+
+theorem parse_some_iff (segment : OtsPrefix) (bytes : HashInput) (query : segment.Query) :
+    segment.parse bytes = some query ↔ bytes = segment.input query := by
+  unfold parse
+  split
+  · rename_i hex
+    rw [Option.some.injEq]
+    constructor
+    · intro heq
+      rw [← heq]
+      exact hex.choose_spec.symm
+    · intro heq
+      exact segment.input_injective (hex.choose_spec.trans heq)
+  · rename_i hnone
+    constructor
+    · intro h
+      cases h
+    · intro heq
+      exact False.elim (hnone ⟨query, heq.symm⟩)
+
+theorem parse_input (segment : OtsPrefix) (query : segment.Query) : segment.parse (segment.input query) = some query :=
+  (segment.parse_some_iff _ query).mpr rfl
+
+noncomputable def combine (low : Digest) (high : High) : HashOutput :=
+  (splitHashOutputEquiv digestBits (by decide)).symm (low, high)
+
+theorem split_combine (low : Digest) (high : High) : splitHashOutput digestBits (combine low high) = (low, high) := by
+  exact (splitHashOutputEquiv digestBits (by decide)).apply_symm_apply (low, high)
+
+theorem truncate_combine (low : Digest) (high : High) : truncateHash (combine low high) = low :=
+  congrArg Prod.fst (split_combine low high)
+
+theorem combine_split (output : HashOutput) :
+    combine (truncateHash output) (splitHashOutput digestBits output).2 = output :=
+  (splitHashOutputEquiv digestBits (by decide)).symm_apply_apply output
+
+noncomputable def answer (segment : OtsPrefix) (tables : Fin segment.digit.val → Digest → Digest)
+    (high : segment.Query → High) (outside : QueryImpl HashSpec Id) : QueryImpl HashSpec Id :=
+  fun bytes => match segment.parse bytes with
+    | none => outside bytes
+    | some query => combine (tables query.1 query.2) (high query)
+
+theorem answer_input (segment : OtsPrefix) (tables : Fin segment.digit.val → Digest → Digest)
+    (high : segment.Query → High) (outside : QueryImpl HashSpec Id) (query : segment.Query) :
+    segment.answer tables high outside (segment.input query) = combine (tables query.1 query.2) (high query) := by
+  simp only [answer, parse_input]
+
+def lows (segment : OtsPrefix) (f : QueryImpl HashSpec Id) : Fin segment.digit.val → Digest → Digest :=
+  fun index value => truncateHash (f (segment.input (index, value)))
+
+def highs (segment : OtsPrefix) (f : QueryImpl HashSpec Id) : segment.Query → High :=
+  fun query => (splitHashOutput digestBits (f (segment.input query))).2
+
+theorem answer_original (segment : OtsPrefix) (f : QueryImpl HashSpec Id) :
+    segment.answer (segment.lows f) (segment.highs f) f = f := by
+  funext bytes
+  cases hparse : segment.parse bytes with
+  | none => simp only [answer, hparse]
+  | some query =>
+      have hinput := (segment.parse_some_iff bytes query).mp hparse
+      rw [hinput, answer_input]
+      exact combine_split (f (segment.input query))
+
+theorem lows_eq_chainFunctions (segment : OtsPrefix) (f : QueryImpl HashSpec Id) :
+    segment.lows f = otsChainFunctions segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx 0 segment.digit.val f := by
+  funext index value
+  rw [otsChainFunctions_apply segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx 0 segment.digit.val f
+    index (by have := (segment.step index).isLt; simpa only [step, Nat.zero_add] using this) value]
+  simp only [lows, input, step]
+  congr 4
+  exact Fin.ext (Nat.zero_add index.val).symm
+
+theorem evaluate_lows (segment : OtsPrefix) (f : QueryImpl HashSpec Id) (secret : Digest) :
+    PartialChainEndpoint.evaluate (segment.lows f) secret =
+      evalWithAnswerFn f (chainWalk segment.parameter segment.lay segment.tree segment.leaf segment.chainIdx 0 segment.digit.val secret) := by
+  rw [lows_eq_chainFunctions, otsChainFunctions_evaluate]
+
+theorem input_private (segment : OtsPrefix) (words : OtsReferenceWords)
+    (hword : segment.digit.val ≤ (words segment.lay segment.tree segment.leaf segment.chainIdx).val) (query : segment.Query) :
+    PrivateOtsPrefixInput segment.parameter words (segment.input query) := by
+  rw [input, privateOtsPrefixInput_chain_iff]
+  exact query.1.isLt.trans_le hword
+
+theorem answer_agrees_outside (segment : OtsPrefix) (words : OtsReferenceWords)
+    (hword : segment.digit.val ≤ (words segment.lay segment.tree segment.leaf segment.chainIdx).val)
+    (tables : Fin segment.digit.val → Digest → Digest) (high : segment.Query → High) (outside : QueryImpl HashSpec Id) :
+    AgreeOutsideOtsPrefixes segment.parameter words (segment.answer tables high outside) outside := by
+  intro bytes hnot
+  cases hparse : segment.parse bytes with
+  | none => simp only [answer, hparse]
+  | some query =>
+      have hinput := (segment.parse_some_iff bytes query).mp hparse
+      exact False.elim (hnot (hinput ▸ segment.input_private words hword query))
+
+theorem mask_answer (segment : OtsPrefix) (words : OtsReferenceWords)
+    (hword : segment.digit.val ≤ (words segment.lay segment.tree segment.leaf segment.chainIdx).val)
+    (tables : Fin segment.digit.val → Digest → Digest) (high : segment.Query → High) (outside : QueryImpl HashSpec Id) :
+    maskOtsPrefixes segment.parameter words (segment.answer tables high outside) = maskOtsPrefixes segment.parameter words outside :=
+  maskOtsPrefixes_congr (segment.answer_agrees_outside words hword tables high outside)
+
+end OtsPrefix
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixRawOracle.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixRawOracle.lean
new file mode 100644
index 000000000..47beccc58
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixRawOracle.lean
@@ -0,0 +1,94 @@
+import SphincsSecurity.Proof.Ots.OtsPrefixRawSampling
+namespace SphincsSecurity.Concrete.OtsPrefix
+
+open _root_.OracleComp OracleSpec
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def rawAnswer (segment : OtsPrefix) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs)
+    (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+    (encoding : canonicalEncodingInputs segment.parameter → HashOutput)
+    (tables : Fin segment.digit.val → Digest → Digest) (high : segment.Query → High)
+    (remaining : segment.RemainingRows inputs hencoding hgraph) : QueryImpl HashSpec Id :=
+  finiteHashAnswer ∅ inputs (joinEncodingTable segment.parameter inputs hencoding encoding
+    (segment.joinNonencoding inputs hencoding hgraph tables high remaining))
+
+noncomputable def auxiliaryAnswer (segment : OtsPrefix) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs)
+    (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+    (encoding : canonicalEncodingInputs segment.parameter → HashOutput)
+    (remaining : segment.RemainingRows inputs hencoding hgraph) : QueryImpl HashSpec Id :=
+  segment.rawAnswer inputs hencoding hgraph encoding (fun _ _ => 0) (fun _ => 0) remaining
+
+theorem rawAnswer_prefix (segment : OtsPrefix) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs)
+    (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+    (encoding : canonicalEncodingInputs segment.parameter → HashOutput)
+    (tables : Fin segment.digit.val → Digest → Digest) (high : segment.Query → High)
+    (remaining : segment.RemainingRows inputs hencoding hgraph) (query : segment.Query) :
+    segment.rawAnswer inputs hencoding hgraph encoding tables high remaining (segment.input query) =
+      combine (tables query.1 query.2) (high query) := by
+  rw [rawAnswer, finiteHashAnswer_none ∅ inputs _ _ (hgraph (segment.input_mem_graph query)) (by simp)]
+  exact (UniformTableSplit.join_outside (encodingInputCell segment.parameter inputs hencoding)
+    (encodingInputCell_injective segment.parameter inputs hencoding) encoding _
+    (segment.nonencodingCell inputs hencoding hgraph query)).trans
+    (segment.joinNonencoding_prefix inputs hencoding hgraph tables high remaining query)
+
+theorem rawAnswer_other (segment : OtsPrefix) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs)
+    (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+    (encoding : canonicalEncodingInputs segment.parameter → HashOutput)
+    (first second : Fin segment.digit.val → Digest → Digest) (firstHigh secondHigh : segment.Query → High)
+    (remaining : segment.RemainingRows inputs hencoding hgraph) (bytes : HashInput) (hparse : segment.parse bytes = none) :
+    segment.rawAnswer inputs hencoding hgraph encoding first firstHigh remaining bytes =
+      segment.rawAnswer inputs hencoding hgraph encoding second secondHigh remaining bytes := by
+  by_cases hin : bytes ∈ inputs
+  · rw [rawAnswer, rawAnswer, finiteHashAnswer_none ∅ inputs _ _ hin (by simp),
+      finiteHashAnswer_none ∅ inputs _ _ hin (by simp)]
+    by_cases henc : bytes ∈ canonicalEncodingInputs segment.parameter
+    · exact (UniformTableSplit.join_embed (encodingInputCell segment.parameter inputs hencoding)
+        (encodingInputCell_injective segment.parameter inputs hencoding) encoding _ ⟨bytes, henc⟩).trans
+        (UniformTableSplit.join_embed (encodingInputCell segment.parameter inputs hencoding)
+          (encodingInputCell_injective segment.parameter inputs hencoding) encoding _ ⟨bytes, henc⟩).symm
+    · let cell : UniformTableSplit.Outside (encodingInputCell segment.parameter inputs hencoding) :=
+        ⟨⟨bytes, hin⟩, UniformTableSplit.inclusion_not_range hencoding _ henc⟩
+      have hcell : cell ∉ Set.range (segment.nonencodingCell inputs hencoding hgraph) := by
+        rintro ⟨query, heq⟩
+        have hbytes : segment.input query = bytes := congrArg (fun value => value.val.val) heq
+        have hsome := (segment.parse_some_iff bytes query).mpr hbytes.symm
+        rw [hparse] at hsome
+        cases hsome
+      calc
+        _ = segment.joinNonencoding inputs hencoding hgraph first firstHigh remaining cell :=
+          UniformTableSplit.join_outside (encodingInputCell segment.parameter inputs hencoding)
+            (encodingInputCell_injective segment.parameter inputs hencoding) encoding _ cell
+        _ = remaining ⟨cell, hcell⟩ :=
+          UniformTableSplit.join_outside (segment.nonencodingCell inputs hencoding hgraph)
+            (segment.nonencodingCell_injective inputs hencoding hgraph) _ remaining ⟨cell, hcell⟩
+        _ = segment.joinNonencoding inputs hencoding hgraph second secondHigh remaining cell :=
+          (UniformTableSplit.join_outside (segment.nonencodingCell inputs hencoding hgraph)
+            (segment.nonencodingCell_injective inputs hencoding hgraph) _ remaining ⟨cell, hcell⟩).symm
+        _ = _ :=
+          (UniformTableSplit.join_outside (encodingInputCell segment.parameter inputs hencoding)
+            (encodingInputCell_injective segment.parameter inputs hencoding) encoding _ cell).symm
+  · simp only [rawAnswer, finiteHashAnswer, QueryCache.empty_apply, Option.getD_none, dif_neg hin]
+
+theorem rawAnswer_eq (segment : OtsPrefix) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs)
+    (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+    (encoding : canonicalEncodingInputs segment.parameter → HashOutput)
+    (tables : Fin segment.digit.val → Digest → Digest) (high : segment.Query → High)
+    (remaining : segment.RemainingRows inputs hencoding hgraph) :
+    segment.rawAnswer inputs hencoding hgraph encoding tables high remaining =
+      segment.answer tables high (segment.auxiliaryAnswer inputs hencoding hgraph encoding remaining) := by
+  funext bytes
+  cases hparse : segment.parse bytes with
+  | none =>
+      rw [answer, hparse]
+      exact segment.rawAnswer_other inputs hencoding hgraph encoding _ _ _ _ remaining bytes hparse
+  | some query =>
+      rw [(segment.parse_some_iff bytes query).mp hparse, rawAnswer_prefix, answer_input]
+
+end SphincsSecurity.Concrete.OtsPrefix
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixRawSampling.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixRawSampling.lean
new file mode 100644
index 000000000..fcaa34f5e
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixRawSampling.lean
@@ -0,0 +1,95 @@
+import SphincsSecurity.Proof.Ots.OtsPrefixOracle
+import SphincsSecurity.Proof.Ots.ReferenceFamilySeed
+namespace SphincsSecurity.Concrete.OtsPrefix
+
+open _root_.OracleComp OracleSpec
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalPayloadInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+theorem input_mem_graph (segment : OtsPrefix) (query : segment.Query) :
+    segment.input query ∈ canonicalGraphInputs segment.parameter := by
+  rw [canonicalGraphInputs, Finset.mem_biUnion]
+  simp only [Finset.mem_univ, true_and]
+  refine ⟨.chain segment.lay segment.tree segment.leaf segment.chainIdx (segment.step query.1), ?_⟩
+  apply Finset.mem_image.mpr
+  refine ⟨[query.2].flatMap digestBytes, flatMap_mem_canonicalPayloadInputs _ (by change 1 ≤ numChains; decide), ?_⟩
+  simp only [List.flatMap_cons, List.flatMap_nil, List.append_nil, input, Position.domain]
+
+theorem input_not_encoding (segment : OtsPrefix) (query : segment.Query) :
+    segment.input query ∉ canonicalEncodingInputs segment.parameter := by
+  intro h
+  rw [canonicalEncodingInputs] at h
+  simp only [Finset.mem_biUnion, Finset.mem_univ, true_and, Finset.mem_image] at h
+  obtain ⟨position, pair, heq⟩ := h
+  have hencoding : AtEncodingPosition segment.parameter (segment.input query) position := ⟨_, heq.symm⟩
+  exact hencoding.not_atPosition
+    (.chain segment.lay segment.tree segment.leaf segment.chainIdx (segment.step query.1)) ⟨digestBytes query.2, rfl⟩
+
+noncomputable def nonencodingCell (segment : OtsPrefix) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs)
+    (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs) (query : segment.Query) :
+    UniformTableSplit.Outside (encodingInputCell segment.parameter inputs hencoding) :=
+  ⟨⟨segment.input query, hgraph (segment.input_mem_graph query)⟩,
+    UniformTableSplit.inclusion_not_range hencoding _ (segment.input_not_encoding query)⟩
+
+theorem nonencodingCell_injective (segment : OtsPrefix) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs)
+    (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs) :
+    Function.Injective (segment.nonencodingCell inputs hencoding hgraph) := by
+  intro left right heq
+  exact segment.input_injective (congrArg (fun cell => cell.val.val) heq)
+
+noncomputable def splitRows (segment : OtsPrefix) :
+    (segment.Query → HashOutput) ≃ (Fin segment.digit.val → Digest → Digest) × (segment.Query → High) where
+  toFun rows := (fun level input => truncateHash (rows (level, input)), fun query => (splitHashOutput digestBits (rows query)).2)
+  invFun pair query := combine (pair.1 query.1 query.2) (pair.2 query)
+  left_inv rows := funext fun query => combine_split (rows query)
+  right_inv pair := Prod.ext
+    (funext fun level => funext fun input => truncate_combine (pair.1 level input) (pair.2 (level, input)))
+    (funext fun query => congrArg Prod.snd (split_combine (pair.1 query.1 query.2) (pair.2 query)))
+
+theorem uniform_rows (segment : OtsPrefix) :
+    PMF.uniformOfFintype (segment.Query → HashOutput) =
+      (PMF.uniformOfFintype (Fin segment.digit.val → Digest → Digest)).bind (fun tables =>
+        (PMF.uniformOfFintype (segment.Query → High)).map (fun high => fun query => combine (tables query.1 query.2) (high query))) := by
+  have h := PMF.uniformOfFintype_map_of_bijective segment.splitRows.symm segment.splitRows.symm.bijective
+  rw [UniformTableSplit.uniform_product, PMF.map_bind] at h
+  simpa only [PMF.map_comp, Function.comp_def, splitRows, Equiv.coe_fn_symm_mk] using h.symm
+
+abbrev RemainingRows (segment : OtsPrefix) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs)
+    (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs) :=
+  UniformTableSplit.Outside (segment.nonencodingCell inputs hencoding hgraph) → HashOutput
+
+noncomputable def joinNonencoding (segment : OtsPrefix) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs)
+    (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+    (tables : Fin segment.digit.val → Digest → Digest) (high : segment.Query → High)
+    (remaining : segment.RemainingRows inputs hencoding hgraph) : NonencodingRows segment.parameter inputs hencoding :=
+  UniformTableSplit.join (segment.nonencodingCell inputs hencoding hgraph)
+    (segment.nonencodingCell_injective inputs hencoding hgraph)
+    (fun query => combine (tables query.1 query.2) (high query)) remaining
+
+theorem joinNonencoding_prefix (segment : OtsPrefix) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs)
+    (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+    (tables : Fin segment.digit.val → Digest → Digest) (high : segment.Query → High)
+    (remaining : segment.RemainingRows inputs hencoding hgraph) (query : segment.Query) :
+    segment.joinNonencoding inputs hencoding hgraph tables high remaining
+        (segment.nonencodingCell inputs hencoding hgraph query) = combine (tables query.1 query.2) (high query) :=
+  UniformTableSplit.join_embed _ _ _ _ _
+
+theorem uniform_nonencoding (segment : OtsPrefix) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs)
+    (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs) :
+    PMF.uniformOfFintype (NonencodingRows segment.parameter inputs hencoding) =
+      (PMF.uniformOfFintype (Fin segment.digit.val → Digest → Digest)).bind (fun tables =>
+        (PMF.uniformOfFintype (segment.Query → High)).bind (fun high =>
+          (PMF.uniformOfFintype (segment.RemainingRows inputs hencoding hgraph)).map
+            (segment.joinNonencoding inputs hencoding hgraph tables high))) := by
+  rw [UniformTableSplit.uniform_join (segment.nonencodingCell inputs hencoding hgraph)
+    (segment.nonencodingCell_injective inputs hencoding hgraph), segment.uniform_rows]
+  simp only [PMF.bind_bind, PMF.bind_map, Function.comp_def]
+  rfl
+
+end SphincsSecurity.Concrete.OtsPrefix
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixReferenceSeed.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixReferenceSeed.lean
new file mode 100644
index 000000000..707ab0b94
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixReferenceSeed.lean
@@ -0,0 +1,67 @@
+import SphincsSecurity.Proof.Ots.OtsPrefixRawSampling
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+namespace OtsPrefix
+
+structure ReferenceAuxSeed (segment : OtsPrefix) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs)
+    (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs) where
+  high : segment.Query → High
+  remaining : segment.RemainingRows inputs hencoding hgraph
+  selectedRows : EncodingPosition → Fin encodingAttemptLimit → HashOutput
+  encoding : canonicalEncodingInputs segment.parameter → HashOutput
+
+noncomputable def referenceAuxSeedLaw (segment : OtsPrefix) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs)
+    (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs) (selections : ReferenceFamily) :
+    PMF (segment.ReferenceAuxSeed inputs hencoding hgraph) :=
+  (PMF.uniformOfFintype (segment.Query → High)).bind (fun high =>
+    (PMF.uniformOfFintype (segment.RemainingRows inputs hencoding hgraph)).bind (fun remaining =>
+      (FirstSuccessFamily.afterSelect decodeEncodingOutput encodingAttemptLimit decodeEncodingOutput_invalid_nonempty selections).bind
+        (fun selectedRows => (PMF.uniformOfFintype (canonicalEncodingInputs segment.parameter → HashOutput)).map
+          (fun encoding => ⟨high, remaining, selectedRows, encoding⟩))))
+
+noncomputable def referenceSeed (segment : OtsPrefix) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs)
+    (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs) (selections : ReferenceFamily)
+    (tables : Fin segment.digit.val → Digest → Digest) (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph) :
+    ReferenceFamilySeed segment.parameter inputs hencoding :=
+  ⟨selections, segment.joinNonencoding inputs hencoding hgraph tables auxiliary.high auxiliary.remaining,
+    auxiliary.selectedRows, auxiliary.encoding⟩
+
+theorem referenceFamilySeedLawAt_eq_prefix (segment : OtsPrefix) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs)
+    (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs) (selections : ReferenceFamily) :
+    referenceFamilySeedLawAt segment.parameter inputs hencoding selections =
+      (PMF.uniformOfFintype (Fin segment.digit.val → Digest → Digest)).bind (fun tables =>
+        (segment.referenceAuxSeedLaw inputs hencoding hgraph selections).map
+          (segment.referenceSeed inputs hencoding hgraph selections tables)) := by
+  rw [referenceFamilySeedLawAt, segment.uniform_nonencoding inputs hencoding hgraph]
+  simp only [PMF.bind_bind, PMF.bind_map, referenceAuxSeedLaw, PMF.map_bind, PMF.map_comp, Function.comp_def]
+  rfl
+
+end OtsPrefix
+
+theorem referenceFamilyOracleSample_eq_prefixSeed (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+    (hgraph : canonicalGraphInputs key.parameter ⊆ inputs)
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (chainIdx : ChainIndex) (digit : ReferenceFamily → Digit) :
+    referenceFamilyOracleSample key inputs hencoding =
+      (FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit).bind (fun selections =>
+        let segment : OtsPrefix := ⟨key.parameter, lay, tree, leaf, chainIdx, digit selections⟩
+        (PMF.uniformOfFintype (Fin segment.digit.val → Digest → Digest)).bind (fun tables =>
+          (segment.referenceAuxSeedLaw inputs hencoding hgraph selections).map (fun auxiliary =>
+            (selections, referenceFamilySeedTable key inputs hencoding
+              (segment.referenceSeed inputs hencoding hgraph selections tables auxiliary))))) := by
+  rw [referenceFamilyOracleSample_eq_seed, referenceFamilySeedLaw, PMF.map_bind]
+  apply congrArg (FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit).bind
+  funext selections
+  rw [OtsPrefix.referenceFamilySeedLawAt_eq_prefix
+    ⟨key.parameter, lay, tree, leaf, chainIdx, digit selections⟩ inputs hencoding hgraph selections]
+  simp only [PMF.map_bind, PMF.map_comp, Function.comp_def, OtsPrefix.referenceSeed]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixSecretSampling.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixSecretSampling.lean
new file mode 100644
index 000000000..22c96f978
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixSecretSampling.lean
@@ -0,0 +1,59 @@
+import SphincsSecurity.Proof.Ots.OtsPrefixFrontier
+import SphincsSecurity.Proof.Base.UniformTableSplit
+namespace SphincsSecurity.Concrete.OtsPrefix
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+theorem replaceChain_self (segment : OtsPrefix) (secrets : OtsFrontierValues) (value : Digest) :
+    segment.replaceChain secrets value segment.lay segment.tree segment.leaf segment.chainIdx = value := by
+  simp only [replaceChain, SameChain, and_self, ↓reduceIte]
+
+theorem replaceChain_replaceChain (segment : OtsPrefix) (secrets : OtsFrontierValues) (first second : Digest) :
+    segment.replaceChain (segment.replaceChain secrets first) second = segment.replaceChain secrets second := by
+  funext lay tree leaf chainIdx
+  by_cases h : segment.SameChain lay tree leaf chainIdx <;> simp only [replaceChain, h, ↓reduceIte]
+
+theorem replaceChain_current (segment : OtsPrefix) (secrets : OtsFrontierValues) :
+    segment.replaceChain secrets (secrets segment.lay segment.tree segment.leaf segment.chainIdx) = secrets := by
+  funext lay tree leaf chainIdx
+  by_cases h : segment.SameChain lay tree leaf chainIdx
+  · obtain ⟨rfl, rfl, rfl, rfl⟩ := h
+    exact segment.replaceChain_self secrets _
+  · simp only [replaceChain, h, ↓reduceIte]
+
+abbrev ErasedSecrets (segment : OtsPrefix) :=
+  {secrets : OtsFrontierValues // secrets segment.lay segment.tree segment.leaf segment.chainIdx = 0}
+
+instance (segment : OtsPrefix) : Nonempty segment.ErasedSecrets := ⟨⟨fun _ _ _ _ => 0, rfl⟩⟩
+
+def secretSplit (segment : OtsPrefix) : OtsFrontierValues ≃ segment.ErasedSecrets × Digest where
+  toFun secrets := (⟨segment.replaceChain secrets 0, segment.replaceChain_self secrets 0⟩,
+    secrets segment.lay segment.tree segment.leaf segment.chainIdx)
+  invFun pair := segment.replaceChain pair.1.val pair.2
+  left_inv secrets := (segment.replaceChain_replaceChain secrets 0 _).trans (segment.replaceChain_current secrets)
+  right_inv pair := by
+    apply Prod.ext
+    · apply Subtype.ext
+      exact (segment.replaceChain_replaceChain pair.1.val pair.2 0).trans
+        (by simpa only [pair.1.property] using segment.replaceChain_current pair.1.val)
+    · exact segment.replaceChain_self pair.1.val pair.2
+
+theorem uniform_secrets (segment : OtsPrefix) :
+    PMF.uniformOfFintype OtsFrontierValues =
+      (PMF.uniformOfFintype segment.ErasedSecrets).bind (fun other =>
+        (PMF.uniformOfFintype Digest).map (segment.replaceChain other.val)) := by
+  have h := PMF.uniformOfFintype_map_of_bijective segment.secretSplit.symm segment.secretSplit.symm.bijective
+  rw [UniformTableSplit.uniform_product, PMF.map_bind] at h
+  simpa only [PMF.map_comp, Function.comp_def, secretSplit, Equiv.coe_fn_symm_mk] using h.symm
+
+theorem sampleOtsSecrets_eq_split (segment : OtsPrefix) :
+    𝒟[sampleOtsSecrets] = (do
+      let other ← 𝒟[PMF.uniformOfFintype segment.ErasedSecrets]
+      let secret ← 𝒟[PMF.uniformOfFintype Digest]
+      pure (segment.replaceChain other.val secret) : SPMF OtsFrontierValues) := by
+  rw [sampleOtsSecrets, evalDist_uniformSample, segment.uniform_secrets]
+  simp only [← PMF.monad_bind_eq_bind, ← PMF.monad_map_eq_map, evalDist_bind, map_eq_bind_pure_comp,
+    Function.comp_apply, evalDist_pure]
+
+end SphincsSecurity.Concrete.OtsPrefix
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixSeedAllocation.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixSeedAllocation.lean
new file mode 100644
index 000000000..6b8be01a5
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixSeedAllocation.lean
@@ -0,0 +1,91 @@
+import SphincsSecurity.Proof.Ots.OtsPrefixSeedGame
+import SphincsSecurity.Proof.Ots.ReferenceFamilyAllocation
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+theorem OtsPrefix.referenceSeedGame_counted (segment : OtsPrefix) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs) (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+    (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph)
+    (root : Digest) (secrets : OtsFrontierValues) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords)
+    (hword : referenceFamilyWords selections dummy segment.lay segment.tree segment.leaf segment.chainIdx = segment.digit)
+    (tables : Fin segment.digit.val → Digest → Digest) (adversary : Adversary) :
+    let key : SecretKey := ⟨segment.parameter, root, secrets, ftsSecret⟩
+    let oracle := finiteHashAnswer ∅ inputs (referenceFamilySeedTable key inputs hencoding
+      (segment.referenceSeed inputs hencoding hgraph selections tables auxiliary))
+    (fun result => (result.1, QueryCap.calls segment.Selects result.2)) <$>
+      referenceRecordedRest key oracle (canonicalGraphLabels segment.parameter secrets ftsSecret oracle) selections dummy adversary =
+      simulateQ (segment.fixedImpl tables) (QueryCap.counted PartialChainEndpoint.IsPrefixQuery
+        (segment.seedGame inputs hencoding hgraph auxiliary (segment.replaceChain secrets 0) ftsSecret
+          (referenceFamilyWords selections dummy)
+          (PartialChainEndpoint.evaluate tables (secrets segment.lay segment.tree segment.leaf segment.chainIdx)) adversary)) := by
+  dsimp only
+  rw [referenceRecordedRest, ← simulateQ_map, QueryCap.recorded_counted, segment.seedGame_replaceSecret, OtsPrefix.seedGame,
+    segment.game_counted_source tables auxiliary.high _ ftsSecret (referenceFamilyWords selections dummy) (by rw [hword])]
+  rw [segment.referenceSeedFrontier_eq inputs hencoding hgraph auxiliary root secrets ftsSecret selections _ hword tables,
+    segment.referenceSeedOracle_eq inputs hencoding hgraph auxiliary root secrets ftsSecret selections _ hword tables]
+
+abbrev PrefixCountedResult := PublicParameter × ReferenceFamily × ((Bool × SigningBoundaryTrace) × Nat)
+
+noncomputable def ReferenceRecordedResult.prefixCounted (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords)
+    (result : ReferenceRecordedResult) : PrefixCountedResult :=
+  (result.1, result.2.1, result.2.2.1,
+    QueryCap.calls (OtsPrefix.atAddress result.1 (referenceFamilyWords result.2.1 dummy) address).Selects result.2.2.2)
+
+noncomputable def prefixCountedSeedRest (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (hgraph : canonicalGraphInputs key.parameter ⊆ inputs)
+    (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords) (adversary : Adversary) : SPMF PrefixCountedResult := do
+  let selections ← 𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit]
+  let words := referenceFamilyWords selections dummy
+  let segment := OtsPrefix.atAddress key.parameter words address
+  let tables ← 𝒟[PMF.uniformOfFintype (Fin segment.digit.val → Digest → Digest)]
+  let auxiliary ← 𝒟[segment.referenceAuxSeedLaw inputs hencoding hgraph selections]
+  let result ← 𝒟[simulateQ (segment.fixedImpl tables) (QueryCap.counted PartialChainEndpoint.IsPrefixQuery
+    (segment.seedGame inputs hencoding hgraph auxiliary (segment.replaceChain key.otsSecret 0) key.ftsSecret words
+      (PartialChainEndpoint.evaluate tables (key.otsSecret address.1 address.2.1 address.2.2.1 address.2.2.2)) adversary))]
+  pure (key.parameter, selections, result)
+
+theorem prefixCountedSeedRest_eq (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (hgraph : canonicalGraphInputs key.parameter ⊆ inputs)
+    (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    prefixCountedSeedRest key inputs hencoding hgraph address dummy adversary = (do
+      let reference ← 𝒟[referenceFamilyOracleSample key inputs hencoding]
+      let oracle := finiteHashAnswer ∅ inputs reference.2
+      let result ← 𝒟[referenceRecordedRest key oracle
+        (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret oracle) reference.1 dummy adversary]
+      pure (ReferenceRecordedResult.prefixCounted address dummy (key.parameter, reference.1, result))) := by
+  rw [referenceFamilyOracleSample_eq_prefixSeed key inputs hencoding hgraph address.1 address.2.1 address.2.2.1 address.2.2.2
+    (fun selections => referenceFamilyWords selections dummy address.1 address.2.1 address.2.2.1 address.2.2.2)]
+  simp only [← PMF.monad_bind_eq_bind, ← PMF.monad_map_eq_map, evalDist_bind, evalDist_map, bind_assoc, bind_map_left]
+  unfold prefixCountedSeedRest
+  apply congrArg (𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit] >>= ·)
+  funext selections
+  let words := referenceFamilyWords selections dummy
+  let segment := OtsPrefix.atAddress key.parameter words address
+  apply congrArg (𝒟[PMF.uniformOfFintype (Fin segment.digit.val → Digest → Digest)] >>= ·)
+  funext tables
+  apply congrArg (𝒟[segment.referenceAuxSeedLaw inputs hencoding hgraph selections] >>= ·)
+  funext auxiliary
+  rw [← segment.referenceSeedGame_counted inputs hencoding hgraph auxiliary key.root key.otsSecret key.ftsSecret
+    selections dummy rfl tables adversary, evalDist_map, bind_map_left]
+  rfl
+
+noncomputable def prefixCountedSourceGame (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords) (adversary : Adversary) : SPMF PrefixCountedResult := do
+  let parameter ← 𝒟[sampleParameter]
+  let otsSecret ← 𝒟[sampleOtsSecrets]
+  let ftsSecret ← 𝒟[sampleFtsSecrets]
+  prefixCountedSeedRest ⟨parameter, 0, otsSecret, ftsSecret⟩ inputs (hencoding parameter) (hgraph parameter) address dummy adversary
+
+theorem prefixCountedSourceGame_eq (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    prefixCountedSourceGame inputs hencoding hgraph address dummy adversary =
+      ReferenceRecordedResult.prefixCounted address dummy <$> referenceRecordedGame inputs hencoding dummy adversary := by
+  simp only [prefixCountedSourceGame, referenceRecordedGame, prefixCountedSeedRest_eq, map_bind, map_pure]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixSeedGame.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixSeedGame.lean
new file mode 100644
index 000000000..01ac74811
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixSeedGame.lean
@@ -0,0 +1,47 @@
+import SphincsSecurity.Proof.Ots.OtsPrefixSeedReconstruction
+import SphincsSecurity.Proof.Ots.OtsPrefixSimulation
+import SphincsSecurity.Proof.Ots.ReferenceFamilyGame
+namespace SphincsSecurity.Concrete.OtsPrefix
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+variable (segment : OtsPrefix) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs)
+  (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+
+noncomputable def seedGame (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph)
+    (secrets : OtsFrontierValues) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (endpoint : Digest) (adversary : Adversary) : OracleComp segment.World (Bool × SigningBoundaryTrace) :=
+  segment.game auxiliary.high (segment.seedOracle inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint)
+    ftsSecret words (segment.seedFrontier inputs hencoding hgraph auxiliary secrets words endpoint) adversary
+
+theorem seedGame_replaceSecret (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph)
+    (secrets : OtsFrontierValues) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (endpoint replacement : Digest) (adversary : Adversary) :
+    segment.seedGame inputs hencoding hgraph auxiliary (segment.replaceChain secrets replacement) ftsSecret words endpoint adversary =
+      segment.seedGame inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary := by
+  rw [seedGame, seedGame, seedOracle_replaceSecret, seedFrontier_replaceSecret]
+
+theorem referenceSeedGame_eq (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph)
+    (root : Digest) (secrets : OtsFrontierValues) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords)
+    (hword : referenceFamilyWords selections dummy segment.lay segment.tree segment.leaf segment.chainIdx = segment.digit)
+    (tables : Fin segment.digit.val → Digest → Digest) (adversary : Adversary) :
+    let key : SecretKey := ⟨segment.parameter, root, secrets, ftsSecret⟩
+    let oracle := finiteHashAnswer ∅ inputs (referenceFamilySeedTable key inputs hencoding
+      (segment.referenceSeed inputs hencoding hgraph selections tables auxiliary))
+    referenceFamilyFrontierRest key oracle (canonicalGraphLabels segment.parameter secrets ftsSecret oracle) selections dummy adversary =
+      simulateQ (segment.fixedImpl tables)
+        (segment.seedGame inputs hencoding hgraph auxiliary (segment.replaceChain secrets 0) ftsSecret
+          (referenceFamilyWords selections dummy)
+          (PartialChainEndpoint.evaluate tables (secrets segment.lay segment.tree segment.leaf segment.chainIdx)) adversary) := by
+  dsimp only
+  rw [seedGame_replaceSecret, seedGame,
+    segment.fixedImpl_game tables auxiliary.high _ ftsSecret (referenceFamilyWords selections dummy) (by rw [hword])]
+  rw [referenceFamilyFrontierRest, causalFrontierGame_eq,
+    segment.referenceSeedFrontier_eq inputs hencoding hgraph auxiliary root secrets ftsSecret selections _ hword tables,
+    segment.referenceSeedOracle_eq inputs hencoding hgraph auxiliary root secrets ftsSecret selections _ hword tables]
+
+end SphincsSecurity.Concrete.OtsPrefix
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixSeedReconstruction.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixSeedReconstruction.lean
new file mode 100644
index 000000000..9f66de218
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixSeedReconstruction.lean
@@ -0,0 +1,134 @@
+import SphincsSecurity.Proof.Ots.OtsPrefixFrontier
+import SphincsSecurity.Proof.Ots.OtsPrefixRawOracle
+import SphincsSecurity.Proof.Ots.OtsPrefixReferenceSeed
+namespace SphincsSecurity.Concrete.OtsPrefix
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+variable (segment : OtsPrefix) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs)
+  (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+
+noncomputable def encodingFromMessages (parameter : PublicParameter) (messages : EncodingPosition → Digest)
+    (rows : EncodingPosition → Fin encodingAttemptLimit → HashOutput)
+    (seed : canonicalEncodingInputs parameter → HashOutput) : canonicalEncodingInputs parameter → HashOutput :=
+  UniformTableSplit.join (referenceFamilyCell parameter messages) (referenceFamilyCell_injective parameter messages)
+    (Function.uncurry rows) (fun cell => seed cell.val)
+
+noncomputable def seedBaseOracle (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph) : QueryImpl HashSpec Id :=
+  segment.auxiliaryAnswer inputs hencoding hgraph (fun _ => 0) auxiliary.remaining
+
+noncomputable def seedFrontier (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph)
+    (secrets : OtsFrontierValues) (words : OtsReferenceWords) (endpoint : Digest) : OtsFrontierValues :=
+  segment.frontierFromEndpoint (segment.seedBaseOracle inputs hencoding hgraph auxiliary) secrets words endpoint
+
+noncomputable def seedMessages (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph)
+    (secrets : OtsFrontierValues) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (endpoint : Digest) : EncodingPosition → Digest :=
+  fun position => evalWithAnswerFn (segment.seedBaseOracle inputs hencoding hgraph auxiliary)
+    (frontierLayerMessage segment.parameter ftsSecret words
+      (segment.seedFrontier inputs hencoding hgraph auxiliary secrets words endpoint)
+      (referenceIndex position.lay position.tree position.leafIdx) position.lay)
+
+noncomputable def seedEncoding (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph)
+    (secrets : OtsFrontierValues) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (endpoint : Digest) : canonicalEncodingInputs segment.parameter → HashOutput :=
+  encodingFromMessages segment.parameter (segment.seedMessages inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint)
+    auxiliary.selectedRows auxiliary.encoding
+
+noncomputable def seedOracle (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph)
+    (secrets : OtsFrontierValues) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (endpoint : Digest) : QueryImpl HashSpec Id :=
+  segment.auxiliaryAnswer inputs hencoding hgraph
+    (segment.seedEncoding inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint) auxiliary.remaining
+
+theorem seedFrontier_replaceSecret (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph)
+    (secrets : OtsFrontierValues) (words : OtsReferenceWords) (endpoint replacement : Digest) :
+    segment.seedFrontier inputs hencoding hgraph auxiliary (segment.replaceChain secrets replacement) words endpoint =
+      segment.seedFrontier inputs hencoding hgraph auxiliary secrets words endpoint :=
+  segment.frontierFromEndpoint_replaceSecret _ secrets words endpoint replacement
+
+theorem seedMessages_replaceSecret (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph)
+    (secrets : OtsFrontierValues) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (endpoint replacement : Digest) :
+    segment.seedMessages inputs hencoding hgraph auxiliary (segment.replaceChain secrets replacement) ftsSecret words endpoint =
+      segment.seedMessages inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint := by
+  funext position
+  simp only [seedMessages, seedFrontier_replaceSecret]
+
+theorem seedOracle_replaceSecret (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph)
+    (secrets : OtsFrontierValues) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (endpoint replacement : Digest) :
+    segment.seedOracle inputs hencoding hgraph auxiliary (segment.replaceChain secrets replacement) ftsSecret words endpoint =
+      segment.seedOracle inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint := by
+  simp only [seedOracle, seedEncoding, seedMessages_replaceSecret]
+
+theorem outsideGraphMessage_eq_seedMessages (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph)
+    (root : Digest) (secrets : OtsFrontierValues) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (hword : words segment.lay segment.tree segment.leaf segment.chainIdx = segment.digit)
+    (tables : Fin segment.digit.val → Digest → Digest) :
+    outsideGraphMessage ⟨segment.parameter, root, secrets, ftsSecret⟩ inputs hencoding
+        (segment.joinNonencoding inputs hencoding hgraph tables auxiliary.high auxiliary.remaining) =
+      segment.seedMessages inputs hencoding hgraph auxiliary secrets ftsSecret words
+        (PartialChainEndpoint.evaluate tables (secrets segment.lay segment.tree segment.leaf segment.chainIdx)) := by
+  funext position
+  change canonicalGraphMessage (canonicalGraphLabels segment.parameter secrets ftsSecret
+    (segment.rawAnswer inputs hencoding hgraph (fun _ => 0) tables auxiliary.high auxiliary.remaining)) position = _
+  rw [rawAnswer_eq]
+  exact segment.graphMessage_answer tables auxiliary.high _ root secrets ftsSecret words hword position
+
+theorem referenceSeedTable_eq_raw (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph)
+    (root : Digest) (secrets : OtsFrontierValues) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (selections : ReferenceFamily) (words : OtsReferenceWords)
+    (hword : words segment.lay segment.tree segment.leaf segment.chainIdx = segment.digit)
+    (tables : Fin segment.digit.val → Digest → Digest) :
+    referenceFamilySeedTable ⟨segment.parameter, root, secrets, ftsSecret⟩ inputs hencoding
+        (segment.referenceSeed inputs hencoding hgraph selections tables auxiliary) =
+      joinEncodingTable segment.parameter inputs hencoding
+        (segment.seedEncoding inputs hencoding hgraph auxiliary secrets ftsSecret words
+          (PartialChainEndpoint.evaluate tables (secrets segment.lay segment.tree segment.leaf segment.chainIdx)))
+        (segment.joinNonencoding inputs hencoding hgraph tables auxiliary.high auxiliary.remaining) := by
+  change joinEncodingTable segment.parameter inputs hencoding
+    (encodingFromMessages segment.parameter
+      (outsideGraphMessage ⟨segment.parameter, root, secrets, ftsSecret⟩ inputs hencoding
+        (segment.joinNonencoding inputs hencoding hgraph tables auxiliary.high auxiliary.remaining))
+      auxiliary.selectedRows auxiliary.encoding)
+    (segment.joinNonencoding inputs hencoding hgraph tables auxiliary.high auxiliary.remaining) = _
+  rw [segment.outsideGraphMessage_eq_seedMessages inputs hencoding hgraph auxiliary root secrets ftsSecret words hword tables]
+  rfl
+
+theorem referenceSeedOracle_eq (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph)
+    (root : Digest) (secrets : OtsFrontierValues) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (selections : ReferenceFamily) (words : OtsReferenceWords)
+    (hword : words segment.lay segment.tree segment.leaf segment.chainIdx = segment.digit)
+    (tables : Fin segment.digit.val → Digest → Digest) :
+    finiteHashAnswer ∅ inputs
+        (referenceFamilySeedTable ⟨segment.parameter, root, secrets, ftsSecret⟩ inputs hencoding
+          (segment.referenceSeed inputs hencoding hgraph selections tables auxiliary)) =
+      segment.answer tables auxiliary.high (segment.seedOracle inputs hencoding hgraph auxiliary secrets ftsSecret words
+        (PartialChainEndpoint.evaluate tables (secrets segment.lay segment.tree segment.leaf segment.chainIdx))) := by
+  rw [segment.referenceSeedTable_eq_raw inputs hencoding hgraph auxiliary root secrets ftsSecret selections words hword tables]
+  exact segment.rawAnswer_eq inputs hencoding hgraph _ tables auxiliary.high auxiliary.remaining
+
+theorem referenceSeedFrontier_eq (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph)
+    (root : Digest) (secrets : OtsFrontierValues) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (selections : ReferenceFamily) (words : OtsReferenceWords)
+    (hword : words segment.lay segment.tree segment.leaf segment.chainIdx = segment.digit)
+    (tables : Fin segment.digit.val → Digest → Digest) :
+    canonicalGraphFrontier secrets (canonicalGraphLabels segment.parameter secrets ftsSecret
+      (finiteHashAnswer ∅ inputs
+        (referenceFamilySeedTable ⟨segment.parameter, root, secrets, ftsSecret⟩ inputs hencoding
+          (segment.referenceSeed inputs hencoding hgraph selections tables auxiliary)))) words =
+      segment.seedFrontier inputs hencoding hgraph auxiliary secrets words
+        (PartialChainEndpoint.evaluate tables (secrets segment.lay segment.tree segment.leaf segment.chainIdx)) := by
+  rw [segment.referenceSeedTable_eq_raw inputs hencoding hgraph auxiliary root secrets ftsSecret selections words hword tables,
+    canonicalGraphLabels_joinEncodingTable segment.parameter secrets ftsSecret inputs hencoding hgraph,
+    canonicalGraphLabels_frontier segment.parameter secrets ftsSecret _ words root]
+  change canonicalFrontierValues ⟨segment.parameter, root, secrets, ftsSecret⟩
+    (segment.rawAnswer inputs hencoding hgraph (fun _ => 0) tables auxiliary.high auxiliary.remaining) words = _
+  rw [rawAnswer_eq, segment.canonicalFrontierValues_answer tables auxiliary.high _ root secrets ftsSecret words hword]
+  rfl
+
+end SphincsSecurity.Concrete.OtsPrefix
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixSimulation.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixSimulation.lean
new file mode 100644
index 000000000..5d69900d8
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixSimulation.lean
@@ -0,0 +1,208 @@
+import SphincsSecurity.Proof.Ots.OtsPrefixOracle
+import SphincsSecurity.Proof.Reference.CausalFrontierGame
+namespace SphincsSecurity.Concrete.OtsPrefix
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] frontierSigningRun boundaryEval frontierRoot
+
+abbrev World (segment : OtsPrefix) := unifSpec + PartialChainEndpoint.PrefixSpec segment.digit.val Digest
+
+noncomputable def fixedImpl (segment : OtsPrefix) (tables : Fin segment.digit.val → Digest → Digest) :
+    QueryImpl segment.World ProbComp :=
+  QueryImpl.id' unifSpec + (fun (query : segment.Query) => pure (tables query.1 query.2) :
+    QueryImpl (PartialChainEndpoint.PrefixSpec segment.digit.val Digest) ProbComp)
+
+noncomputable def hashImpl (segment : OtsPrefix) (high : segment.Query → High)
+    (outside : QueryImpl HashSpec Id) : QueryImpl HashSpec (OracleComp segment.World) :=
+  fun bytes => match segment.parse bytes with
+    | none => pure (outside bytes)
+    | some query => (combine · (high query)) <$> liftM (segment.World.query (.inr query))
+
+noncomputable def worldImpl (segment : OtsPrefix) (high : segment.Query → High)
+    (outside : QueryImpl HashSpec Id) : QueryImpl OracleWorld (OracleComp segment.World)
+  | .inl input => liftM (segment.World.query (.inl input))
+  | .inr bytes => segment.hashImpl high outside bytes
+
+theorem hashImpl_queryBound (segment : OtsPrefix) (high : segment.Query → High)
+    (outside : QueryImpl HashSpec Id) (bytes : HashInput) :
+    (segment.hashImpl high outside bytes).IsQueryBoundP PartialChainEndpoint.IsPrefixQuery 1 := by
+  cases hparse : segment.parse bytes with
+  | none => simp only [hashImpl, hparse, isQueryBoundP_pure]
+  | some query =>
+      simp only [hashImpl, hparse, isQueryBoundP_map_iff, isQueryBoundP_query_iff]
+      exact fun _ => Nat.zero_lt_one
+
+theorem lift_prob_queryBound (segment : OtsPrefix) {Result : Type} (computation : ProbComp Result) :
+    (liftM computation : OracleComp segment.World Result).IsQueryBoundP PartialChainEndpoint.IsPrefixQuery 0 := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => simp only [liftM_pure, isQueryBoundP_pure]
+  | query_bind input next ih =>
+      rw [liftM_bind]
+      change ((liftM (segment.World.query (.inl input)) >>= fun answer => liftM (next answer)) :
+        OracleComp segment.World Result).IsQueryBoundP PartialChainEndpoint.IsPrefixQuery 0
+      simp only [isQueryBoundP_query_bind_iff, PartialChainEndpoint.IsPrefixQuery, not_false_eq_true,
+        true_or, ↓reduceIte, true_and]
+      exact ih
+
+theorem fixedImpl_lift_prob (segment : OtsPrefix) (tables : Fin segment.digit.val → Digest → Digest)
+    {Result : Type} (computation : ProbComp Result) :
+    simulateQ (segment.fixedImpl tables) (liftM computation) = computation := by
+  rw [fixedImpl, QueryImpl.simulateQ_add_liftM_left, simulateQ_id']
+
+private theorem fixedImpl_lift_prob_congr (segment : OtsPrefix) (tables : Fin segment.digit.val → Digest → Digest)
+    {Parameter Result : Type} (work : Parameter → ProbComp Result) (first second : Parameter) (h : first = second) :
+    simulateQ (segment.fixedImpl tables) (liftM (work first)) = work second :=
+  (segment.fixedImpl_lift_prob tables (work first)).trans (congrArg work h)
+
+theorem fixedImpl_hashImpl (segment : OtsPrefix) (tables : Fin segment.digit.val → Digest → Digest)
+    (high : segment.Query → High) (outside : QueryImpl HashSpec Id) (bytes : HashInput) :
+    simulateQ (segment.fixedImpl tables) (segment.hashImpl high outside bytes) =
+      pure (segment.answer tables high outside bytes) := by
+  cases hparse : segment.parse bytes with
+  | none => simp only [hashImpl, answer, hparse, simulateQ_pure]
+  | some query =>
+      simp only [hashImpl, answer, hparse, simulateQ_map, simulateQ_spec_query]
+      rfl
+
+theorem fixedImpl_worldImpl (segment : OtsPrefix) (tables : Fin segment.digit.val → Digest → Digest)
+    (high : segment.Query → High) (outside : QueryImpl HashSpec Id) (input : OracleWorld.Domain) :
+    simulateQ (segment.fixedImpl tables) (segment.worldImpl high outside input) =
+      fixedHashWorld (segment.answer tables high outside) input := by
+  cases input with
+  | inl input => rw [worldImpl, simulateQ_spec_query]; rfl
+  | inr bytes => exact segment.fixedImpl_hashImpl tables high outside bytes
+
+noncomputable def boundary (segment : OtsPrefix) (high : segment.Query → High)
+    (outside : QueryImpl HashSpec Id) {Result : Type} (computation : OracleComp OracleWorld Result) :
+    OracleComp segment.World (Result × SigningBoundaryTrace) :=
+  (simulateQ ((segment.worldImpl high outside).withTrace (signingBoundaryTrace segment.parameter)) computation).run
+
+theorem fixedImpl_boundary (segment : OtsPrefix) (tables : Fin segment.digit.val → Digest → Digest)
+    (high : segment.Query → High) (outside : QueryImpl HashSpec Id) {Result : Type}
+    (computation : OracleComp OracleWorld Result) :
+    simulateQ (segment.fixedImpl tables) (segment.boundary high outside computation) =
+      fixedBoundaryRun segment.parameter (segment.answer tables high outside) computation := by
+  apply simulateQ_writer_compose
+  intro input
+  simp [QueryImpl.withTrace_apply, segment.fixedImpl_worldImpl tables high outside input]
+
+noncomputable def adversaryImpl (segment : OtsPrefix) (root : Digest) (high : segment.Query → High)
+    (outside : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) :
+    QueryImpl (OracleWorld + SigningSpec) (WriterT SigningBoundaryTrace (OracleComp segment.World))
+  | .inl input => (segment.worldImpl high outside).withTrace (signingBoundaryTrace segment.parameter) input
+  | .inr message => WriterT.mk (liftM
+      (frontierSigningRun segment.parameter root (maskOtsPrefixes segment.parameter words outside)
+        ftsSecret words frontier message))
+
+theorem adversaryImpl_signing (segment : OtsPrefix) (root : Digest) (high : segment.Query → High)
+    (outside : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) (message : Message) :
+    segment.adversaryImpl root high outside ftsSecret words frontier (.inr message) =
+      WriterT.mk (liftM (frontierSigningRun segment.parameter root (maskOtsPrefixes segment.parameter words outside)
+        ftsSecret words frontier message) : OracleComp segment.World _) := rfl
+
+private theorem causalFrontierAdversaryImpl_signing (parameter : PublicParameter) (root : Digest)
+    (oracle : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) (message : Message) :
+    causalFrontierAdversaryImpl parameter root oracle ftsSecret words frontier (.inr message) =
+      WriterT.mk (frontierSigningRun parameter root (maskOtsPrefixes parameter words oracle) ftsSecret words frontier message) := rfl
+
+theorem fixedImpl_adversaryImpl (segment : OtsPrefix) (tables : Fin segment.digit.val → Digest → Digest)
+    (root : Digest) (high : segment.Query → High) (outside : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords)
+    (hword : segment.digit.val ≤ (words segment.lay segment.tree segment.leaf segment.chainIdx).val)
+    (frontier : OtsFrontierValues) (input : (OracleWorld + SigningSpec).Domain) :
+    simulateQ (segment.fixedImpl tables)
+        (segment.adversaryImpl root high outside ftsSecret words frontier input).run =
+      (causalFrontierAdversaryImpl segment.parameter root (segment.answer tables high outside)
+        ftsSecret words frontier input).run := by
+  cases input with
+  | inl input =>
+      simp [adversaryImpl, causalFrontierAdversaryImpl, QueryImpl.withTrace_apply,
+        segment.fixedImpl_worldImpl tables high outside input]
+  | inr message =>
+      rw [adversaryImpl_signing, causalFrontierAdversaryImpl_signing, WriterT.run_mk, WriterT.run_mk]
+      exact fixedImpl_lift_prob_congr segment tables
+        (fun oracle => frontierSigningRun segment.parameter root oracle ftsSecret words frontier message) _ _
+        (segment.mask_answer words hword tables high outside).symm
+
+noncomputable def logged {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result) :
+    OracleComp (OracleWorld + SigningSpec) (Result × QueryLog SigningSpec) :=
+  (simulateQ ((QueryImpl.id' (OracleWorld + SigningSpec)).withTraceAppend signingLogFragment) computation).run
+
+noncomputable def adversaryRun (segment : OtsPrefix) (root : Digest) (high : segment.Query → High)
+    (outside : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) {Result : Type}
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) :
+    OracleComp segment.World ((Result × QueryLog SigningSpec) × SigningBoundaryTrace) :=
+  (simulateQ (segment.adversaryImpl root high outside ftsSecret words frontier) (logged computation)).run
+
+theorem fixedImpl_adversaryRun (segment : OtsPrefix) (tables : Fin segment.digit.val → Digest → Digest)
+    (root : Digest) (high : segment.Query → High) (outside : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords)
+    (hword : segment.digit.val ≤ (words segment.lay segment.tree segment.leaf segment.chainIdx).val)
+    (frontier : OtsFrontierValues) {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result) :
+    simulateQ (segment.fixedImpl tables) (segment.adversaryRun root high outside ftsSecret words frontier computation) =
+      causalFrontierAdversaryRun segment.parameter root (segment.answer tables high outside)
+        ftsSecret words frontier computation := by
+  rw [adversaryRun, simulateQ_writer_compose _ _ _
+    (segment.fixedImpl_adversaryImpl tables root high outside ftsSecret words hword frontier)]
+  unfold logged causalFrontierAdversaryRun
+  congr 1
+  apply simulateQ_writerAppend_compose
+  intro input
+  simp [QueryImpl.withTraceAppend_apply]
+
+noncomputable def gameRest (segment : OtsPrefix) (root : Digest) (high : segment.Query → High)
+    (outside : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) (adversary : Adversary) :
+    OracleComp segment.World (Bool × SigningBoundaryTrace) := do
+  let result ← segment.adversaryRun root high outside ftsSecret words frontier (adversary.main ⟨root, segment.parameter⟩)
+  let checked ← segment.boundary high outside (liftM
+    (verify ⟨root, segment.parameter⟩ result.1.1.message result.1.1.signature : OracleComp HashSpec Bool))
+  pure (decide (SigningTranscript.Valid result.1.2 ∧ ¬SigningTranscript.Contains result.1.2 result.1.1) && checked.1,
+    result.2 * checked.2)
+
+theorem fixedImpl_gameRest (segment : OtsPrefix) (tables : Fin segment.digit.val → Digest → Digest)
+    (root : Digest) (high : segment.Query → High) (outside : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords)
+    (hword : segment.digit.val ≤ (words segment.lay segment.tree segment.leaf segment.chainIdx).val)
+    (frontier : OtsFrontierValues) (adversary : Adversary) :
+    simulateQ (segment.fixedImpl tables) (segment.gameRest root high outside ftsSecret words frontier adversary) =
+      causalFrontierGameRest segment.parameter root (segment.answer tables high outside)
+        ftsSecret words frontier adversary := by
+  simp only [gameRest, simulateQ_bind, segment.fixedImpl_adversaryRun tables root high outside ftsSecret words hword frontier]
+  unfold causalFrontierGameRest
+  apply bind_congr
+  intro result
+  rw [fixedImpl_boundary, fixedBoundaryRun_lift_hash, pure_bind, simulateQ_pure]
+
+noncomputable def game (segment : OtsPrefix) (high : segment.Query → High) (outside : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords)
+    (frontier : OtsFrontierValues) (adversary : Adversary) : OracleComp segment.World (Bool × SigningBoundaryTrace) :=
+  (fun result => (result.1, (FreeMonoid.of none) ^ 1212415 * result.2)) <$>
+    segment.gameRest (frontierRoot segment.parameter (maskOtsPrefixes segment.parameter words outside) words frontier)
+      high outside ftsSecret words frontier adversary
+
+theorem fixedImpl_game (segment : OtsPrefix) (tables : Fin segment.digit.val → Digest → Digest)
+    (high : segment.Query → High) (outside : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords)
+    (hword : segment.digit.val ≤ (words segment.lay segment.tree segment.leaf segment.chainIdx).val)
+    (frontier : OtsFrontierValues) (adversary : Adversary) :
+    simulateQ (segment.fixedImpl tables) (segment.game high outside ftsSecret words frontier adversary) =
+      frontierGame segment.parameter (segment.answer tables high outside) ftsSecret words frontier adversary := by
+  rw [game, simulateQ_map, fixedImpl_gameRest segment tables _ high outside ftsSecret words hword frontier,
+    ← causalFrontierGame_eq, causalFrontierGame, segment.mask_answer words hword tables high outside]
+
+theorem fixedImpl_game_original (segment : OtsPrefix) (oracle : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords)
+    (hword : segment.digit.val ≤ (words segment.lay segment.tree segment.leaf segment.chainIdx).val)
+    (frontier : OtsFrontierValues) (adversary : Adversary) :
+    simulateQ (segment.fixedImpl (segment.lows oracle))
+        (segment.game (segment.highs oracle) oracle ftsSecret words frontier adversary) =
+      frontierGame segment.parameter oracle ftsSecret words frontier adversary := by
+  rw [fixedImpl_game segment _ _ _ ftsSecret words hword frontier adversary, answer_original]
+
+end SphincsSecurity.Concrete.OtsPrefix
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixSourceGame.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixSourceGame.lean
new file mode 100644
index 000000000..f590be0aa
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixSourceGame.lean
@@ -0,0 +1,79 @@
+import SphincsSecurity.Proof.Ots.OtsPrefixSeedGame
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+noncomputable def prefixSeedRest (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+    (hgraph : canonicalGraphInputs key.parameter ⊆ inputs)
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (chainIdx : ChainIndex)
+    (dummy : OtsReferenceWords) (adversary : Adversary) : SPMF (ReferenceFamily × (Bool × SigningBoundaryTrace)) := do
+  let selections ← 𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit]
+  let words := referenceFamilyWords selections dummy
+  let segment : OtsPrefix := ⟨key.parameter, lay, tree, leaf, chainIdx, words lay tree leaf chainIdx⟩
+  let tables ← 𝒟[PMF.uniformOfFintype (Fin segment.digit.val → Digest → Digest)]
+  let auxiliary ← 𝒟[segment.referenceAuxSeedLaw inputs hencoding hgraph selections]
+  let result ← 𝒟[simulateQ (segment.fixedImpl tables)
+    (segment.seedGame inputs hencoding hgraph auxiliary (segment.replaceChain key.otsSecret 0) key.ftsSecret words
+      (PartialChainEndpoint.evaluate tables (key.otsSecret lay tree leaf chainIdx)) adversary)]
+  pure (selections, result)
+
+theorem prefixSeedRest_eq (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+    (hgraph : canonicalGraphInputs key.parameter ⊆ inputs)
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (chainIdx : ChainIndex)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    prefixSeedRest key inputs hencoding hgraph lay tree leaf chainIdx dummy adversary = (do
+      let reference ← 𝒟[referenceFamilyOracleSample key inputs hencoding]
+      let oracle := finiteHashAnswer ∅ inputs reference.2
+      let result ← 𝒟[referenceFamilyFrontierRest key oracle
+        (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret oracle) reference.1 dummy adversary]
+      pure (reference.1, result)) := by
+  rw [referenceFamilyOracleSample_eq_prefixSeed key inputs hencoding hgraph lay tree leaf chainIdx
+    (fun selections => referenceFamilyWords selections dummy lay tree leaf chainIdx)]
+  simp only [← PMF.monad_bind_eq_bind, ← PMF.monad_map_eq_map, evalDist_bind, evalDist_map,
+    bind_assoc, bind_map_left]
+  unfold prefixSeedRest
+  apply congrArg (𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit] >>= ·)
+  funext selections
+  let words := referenceFamilyWords selections dummy
+  let segment : OtsPrefix := ⟨key.parameter, lay, tree, leaf, chainIdx, words lay tree leaf chainIdx⟩
+  apply congrArg (𝒟[PMF.uniformOfFintype (Fin segment.digit.val → Digest → Digest)] >>= ·)
+  funext tables
+  apply congrArg (𝒟[segment.referenceAuxSeedLaw inputs hencoding hgraph selections] >>= ·)
+  funext auxiliary
+  rw [segment.referenceSeedGame_eq inputs hencoding hgraph auxiliary key.root key.otsSecret key.ftsSecret selections dummy rfl tables]
+
+noncomputable def prefixSourceGame (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (chainIdx : ChainIndex)
+    (dummy : OtsReferenceWords) (adversary : Adversary) : SPMF (ReferenceFamily × (Bool × SigningBoundaryTrace)) := do
+  let parameter ← 𝒟[sampleParameter]
+  let otsSecret ← 𝒟[sampleOtsSecrets]
+  let ftsSecret ← 𝒟[sampleFtsSecrets]
+  prefixSeedRest ⟨parameter, 0, otsSecret, ftsSecret⟩ inputs (hencoding parameter) (hgraph parameter)
+    lay tree leaf chainIdx dummy adversary
+
+theorem prefixSourceGame_eq (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (chainIdx : ChainIndex)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    prefixSourceGame inputs hencoding hgraph lay tree leaf chainIdx dummy adversary =
+      referenceFamilyGame inputs hencoding dummy adversary := by
+  simp only [prefixSourceGame, referenceFamilyGame, prefixSeedRest_eq]
+
+theorem prefixSourceGame_hashCalls_le (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (chainIdx : ChainIndex)
+    (dummy : OtsReferenceWords) (adversary : Adversary) (q : Nat) (hbound : HasHashQueryBound scheme adversary q)
+    (result : ReferenceFamily × (Bool × SigningBoundaryTrace))
+    (hresult : result ∈ support
+      (prefixSourceGame (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary)
+        (canonicalGraphInputs_subset_gameInputs adversary) lay tree leaf chainIdx dummy adversary)) :
+    result.2.2.hashCalls ≤ q := by
+  rw [prefixSourceGame_eq] at hresult
+  exact referenceFamilyGame_hashCalls_le dummy adversary q hbound result hresult
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixTwoEdgeProbability.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixTwoEdgeProbability.lean
new file mode 100644
index 000000000..d1781c82a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixTwoEdgeProbability.lean
@@ -0,0 +1,86 @@
+import SphincsSecurity.Proof.Chains.AdaptiveChainCapTwoEdge
+import SphincsSecurity.Proof.Reference.ReferenceQueryAllocation
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+attribute [local instance] Classical.propDecidable
+
+noncomputable def prefixTwoEdgeRate (q : Nat) : ENNReal :=
+  ((3 / 2 : ENNReal) + 4 * ((q : ENNReal) / Fintype.card Digest) +
+    2 * ((q : ENNReal) / Fintype.card Digest)^2) / Fintype.card Digest
+
+noncomputable def prefixTwoEdgeGame (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords) (adversary : Adversary) : SPMF Bool := do
+  let parameter ← 𝒟[sampleParameter]
+  let ftsSecret ← 𝒟[sampleFtsSecrets]
+  let selections ← 𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit]
+  let words := referenceFamilyWords selections dummy
+  let segment := OtsPrefix.atAddress parameter words address
+  let other ← 𝒟[PMF.uniformOfFintype segment.ErasedSecrets]
+  let auxiliary ← 𝒟[segment.referenceAuxSeedLaw inputs (hencoding parameter) (hgraph parameter) selections]
+  let result ← 𝒟[PartialChainEndpoint.realRun (fun _ => OtsPrefix.uniformImpl)
+    (fun endpoint => segment.seedGame inputs (hencoding parameter) (hgraph parameter) auxiliary other.val ftsSecret words endpoint adversary)
+    (fun _ _ => none)]
+  pure (decide (PartialChainEndpoint.TwoEdgeEvent result.2.2 result.1))
+
+private theorem probComp_mem_of_evalDist {Result : Type} (computation : ProbComp Result) (result : Result)
+    (hresult : result ∈ support 𝒟[computation]) : result ∈ support computation :=
+  (mem_support_iff_of_evalDist_eq (mx := computation) (mx' := 𝒟[computation]) rfl result).mpr hresult
+
+private theorem pmf_mem_of_evalDist {Result : Type} (law : PMF Result) (result : Result)
+    (hresult : result ∈ support 𝒟[law]) : result ∈ law.support := by
+  change result ∈ (𝒟[law]).support at hresult
+  simpa only [PMF.evalDist_eq, SPMF.support_liftM] using hresult
+
+theorem prefixTwoEdgeGame_le (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords)
+    (adversary : Adversary) (q : Nat) (hbound : HasHashQueryBound scheme adversary q) (hsmall : q < Fintype.card Digest) :
+    Pr[= true | prefixTwoEdgeGame (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) (canonicalGraphInputs_subset_gameInputs adversary) address dummy adversary] ≤
+      (prefixTwoEdgeRate q) * ∑' count, Pr[= count | prefixIdealCostGame (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary) (canonicalGraphInputs_subset_gameInputs adversary)
+        address dummy adversary q] * (count : ENNReal) := by
+  have h : 1 * (∑' result, Pr[= result | prefixTwoEdgeGame (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) (canonicalGraphInputs_subset_gameInputs adversary) address dummy adversary] *
+        (if result = true then 1 else 0)) ≤
+      ∑' count, Pr[= count | prefixIdealCostGame (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary) (canonicalGraphInputs_subset_gameInputs adversary)
+        address dummy adversary q] * ((prefixTwoEdgeRate q) * (count : ENNReal)) := by
+    unfold prefixTwoEdgeGame prefixIdealCostGame
+    apply QueryCap.scaled_expectation_bind_le
+    intro parameter hparameter
+    apply QueryCap.scaled_expectation_bind_le
+    intro ftsSecret _
+    apply QueryCap.scaled_expectation_bind_le
+    intro selections hselections
+    apply QueryCap.scaled_expectation_bind_le
+    intro other _
+    apply QueryCap.scaled_expectation_bind_le
+    intro auxiliary hauxiliary
+    let words := referenceFamilyWords selections dummy
+    let segment := OtsPrefix.atAddress parameter words address
+    let inputs := canonicalGraphGameInputs adversary
+    let hencoding := canonicalEncodingInputs_subset_gameInputs adversary parameter
+    let hgraph := canonicalGraphInputs_subset_gameInputs adversary parameter
+    let computation := fun endpoint => segment.seedGame inputs hencoding hgraph auxiliary other.val ftsSecret words endpoint adversary
+    let cost := fun result : Bool × SigningBoundaryTrace => result.2.hashCalls
+    have hcharge : ∀ endpoint result, result ∈ support (QueryCap.counted PartialChainEndpoint.IsPrefixQuery (computation endpoint)) →
+        result.2 ≤ cost result.1 :=
+      fun endpoint result hresult => segment.seedGame_counted_le inputs hencoding hgraph auxiliary other.val
+        ftsSecret words endpoint adversary result hresult
+    have hreal : ∀ result ∈ (PartialChainEndpoint.realRun (fun _ => OtsPrefix.uniformImpl) computation (fun _ _ => none)).support,
+        cost result.2.1 ≤ q :=
+      prefixObservedRun_hashCalls_le parameter (probComp_mem_of_evalDist _ parameter hparameter) ftsSecret
+        address.1 address.2.1 address.2.2.1 address.2.2.2 dummy adversary selections (pmf_mem_of_evalDist _ selections hselections)
+        q hbound other auxiliary (pmf_mem_of_evalDist _ auxiliary hauxiliary)
+    have htwoEdge := PartialChainEndpoint.realRun_twoEdgeEvent_le_cap_cost (fun _ => OtsPrefix.uniformImpl) computation cost q hcharge hreal hsmall
+    simp only [one_mul, tsum_probOutput_bind_mul, tsum_probOutput_pure_mul]
+    simpa only [prefixTwoEdgeRate, PMF.evalDist_eq, SPMF.probOutput_liftM, PMF.probOutput_eq_apply, decide_eq_true_eq,
+      probEvent_eq_tsum_ite, mul_ite, mul_one, mul_zero,
+      PartialChainEndpoint.expectation_scale] using htwoEdge
+  simpa only [one_mul, mul_ite, mul_one, mul_zero, tsum_ite_eq,
+    mul_left_comm _ (prefixTwoEdgeRate q), ENNReal.tsum_mul_left] using h
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixVisible.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixVisible.lean
new file mode 100644
index 000000000..264a29f48
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixVisible.lean
@@ -0,0 +1,73 @@
+import SphincsSecurity.Proof.Chains.AdaptiveChainAuxiliary
+import SphincsSecurity.Proof.Ots.OtsPrefixObservedRun
+import SphincsSecurity.Proof.Reference.CausalFrontierProgram
+namespace SphincsSecurity.Concrete.OtsPrefix
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+abbrev VisibleWorld (segment : OtsPrefix) := OracleWorld + PartialChainEndpoint.PrefixSpec segment.digit.val Digest
+
+noncomputable def visibleHashImpl (segment : OtsPrefix) (high : segment.Query → High) :
+    QueryImpl HashSpec (OracleComp segment.VisibleWorld) := fun bytes =>
+  match segment.parse bytes with
+  | none => liftM (segment.VisibleWorld.query (.inl (.inr bytes)))
+  | some query => (combine · (high query)) <$> liftM (segment.VisibleWorld.query (.inr query))
+
+noncomputable def visibleWorldImpl (segment : OtsPrefix) (high : segment.Query → High) :
+    QueryImpl OracleWorld (OracleComp segment.VisibleWorld)
+  | .inl input => liftM (segment.VisibleWorld.query (.inl (.inl input)))
+  | .inr bytes => segment.visibleHashImpl high bytes
+
+theorem erase_visibleHashImpl (segment : OtsPrefix) (high : segment.Query → High) (outside : QueryImpl HashSpec Id) (bytes : HashInput) :
+    simulateQ (PartialChainEndpoint.eraseAux outside) (segment.visibleHashImpl high bytes) = segment.hashImpl high outside bytes := by
+  cases hparse : segment.parse bytes <;>
+    simp only [visibleHashImpl, hashImpl, hparse, simulateQ_spec_query, simulateQ_map, PartialChainEndpoint.eraseAux]
+
+theorem erase_visibleWorldImpl (segment : OtsPrefix) (high : segment.Query → High) (outside : QueryImpl HashSpec Id) :
+    (PartialChainEndpoint.eraseAux outside).compose (segment.visibleWorldImpl high) = segment.worldImpl high outside := by
+  funext input
+  cases input with
+  | inl input => simp only [QueryImpl.apply_compose, visibleWorldImpl, simulateQ_spec_query, PartialChainEndpoint.eraseAux, worldImpl]
+  | inr bytes => exact segment.erase_visibleHashImpl high outside bytes
+
+noncomputable def visibleGame (segment : OtsPrefix) (high : segment.Query → High) (outside : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (adversary : Adversary) : OracleComp segment.VisibleWorld (Bool × SigningBoundaryTrace) :=
+  simulateQ (segment.visibleWorldImpl high) (CausalFrontierProgram.game segment.parameter outside ftsSecret words frontier adversary)
+
+theorem erase_visibleGame (segment : OtsPrefix) (high : segment.Query → High) (outside : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (frontier : OtsFrontierValues) (adversary : Adversary) :
+    simulateQ (PartialChainEndpoint.eraseAux outside) (segment.visibleGame high outside ftsSecret words frontier adversary) =
+      segment.game high outside ftsSecret words frontier adversary := by
+  rw [visibleGame, ← QueryImpl.simulateQ_compose, erase_visibleWorldImpl, CausalFrontierProgram.prefix_game]
+
+variable (segment : OtsPrefix) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs) (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+  (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph) (secrets : OtsFrontierValues)
+  (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (adversary : Adversary)
+
+noncomputable def visibleSeedGame (endpoint : Digest) : OracleComp segment.VisibleWorld (Bool × SigningBoundaryTrace) :=
+  segment.visibleGame auxiliary.high (segment.seedOracle inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint)
+    ftsSecret words (segment.seedFrontier inputs hencoding hgraph auxiliary secrets words endpoint) adversary
+
+theorem erase_visibleSeedGame (endpoint : Digest) :
+    simulateQ (PartialChainEndpoint.eraseAux (segment.seedOracle inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint))
+      (segment.visibleSeedGame inputs hencoding hgraph auxiliary secrets ftsSecret words adversary endpoint) =
+        segment.seedGame inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary := by
+  rw [visibleSeedGame, erase_visibleGame]
+  rfl
+
+theorem visibleSeedGame_real :
+    PartialChainEndpoint.realRun (fun endpoint => PartialChainEndpoint.extendAux uniformImpl
+      (segment.seedOracle inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint))
+      (segment.visibleSeedGame inputs hencoding hgraph auxiliary secrets ftsSecret words adversary) (fun _ _ => none) =
+    PartialChainEndpoint.realRun (fun _ => uniformImpl)
+      (fun endpoint => segment.seedGame inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary) (fun _ _ => none) := by
+  simpa only [erase_visibleSeedGame] using
+    (PartialChainEndpoint.realRun_eraseAux (fun _ => uniformImpl)
+      (segment.seedOracle inputs hencoding hgraph auxiliary secrets ftsSecret words)
+      (segment.visibleSeedGame inputs hencoding hgraph auxiliary secrets ftsSecret words adversary) (fun _ _ => none)).symm
+
+end SphincsSecurity.Concrete.OtsPrefix
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixVisibleAccounting.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixVisibleAccounting.lean
new file mode 100644
index 000000000..12113134c
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixVisibleAccounting.lean
@@ -0,0 +1,69 @@
+import SphincsSecurity.Proof.Ots.OtsPrefixVisible
+import SphincsSecurity.Proof.Ots.OtsPrefixAllocation
+namespace SphincsSecurity.Concrete.OtsPrefix
+
+open _root_.OracleComp OracleSpec PartialChainEndpoint
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] frontierSigningRun boundaryEval frontierRoot
+
+theorem visibleWorldImpl_counted (segment : OtsPrefix) (high : segment.Query → High) (input : OracleWorld.Domain) :
+    QueryCap.counted IsPrefixQuery (segment.visibleWorldImpl high input) =
+      (fun answer => (answer, if segment.Selects input then 1 else 0)) <$> segment.visibleWorldImpl high input := by
+  cases input with
+  | inl input =>
+      simp only [visibleWorldImpl, QueryCap.counted_query, IsPrefixQuery, Selects, if_false]
+      rfl
+  | inr bytes =>
+      cases hparse : segment.parse bytes with
+      | none =>
+          simp only [visibleWorldImpl, visibleHashImpl, hparse, QueryCap.counted_query, IsPrefixQuery, Selects, ne_self_iff_false, if_false]
+          rfl
+      | some query =>
+          simp only [visibleWorldImpl, visibleHashImpl, hparse, QueryCap.counted_map, QueryCap.counted_query,
+            IsPrefixQuery, Selects, if_pos (Option.some_ne_none query), if_true, Functor.map_map]
+          rfl
+
+theorem visible_counted_program (segment : OtsPrefix) (high : segment.Query → High) {Result : Type}
+    (computation : OracleComp OracleWorld Result) :
+    QueryCap.counted IsPrefixQuery (simulateQ (segment.visibleWorldImpl high) computation) =
+      simulateQ (segment.visibleWorldImpl high) (QueryCap.counted segment.Selects computation) := by
+  have h := QueryCap.simulate_counted segment.Selects IsPrefixQuery (segment.visibleWorldImpl high)
+    (QueryImpl.id' segment.VisibleWorld) (segment.visibleWorldImpl high)
+    (fun input => by rw [simulateQ_id']; exact segment.visibleWorldImpl_counted high input) computation
+  simpa only [simulateQ_id'] using h
+
+theorem visibleGame_counted_le (segment : OtsPrefix) (high : segment.Query → High) (outside : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (adversary : Adversary) (result : (Bool × SigningBoundaryTrace) × Nat)
+    (hresult : result ∈ support (QueryCap.counted IsPrefixQuery (segment.visibleGame high outside ftsSecret words frontier adversary))) :
+    result.2 ≤ result.1.2.hashCalls := by
+  let charge : CausalFrontierProgram.TraceCharge segment.parameter := {
+    selected := segment.Selects
+    decidable := inferInstance
+    cost := SigningBoundaryTrace.hashCalls
+    cost_mul := SigningBoundaryTrace.hashCalls_mul
+    uniform := fun _ => not_false
+    step := by
+      intro input answer
+      cases input with
+      | inl input => simp only [Selects, if_false, Nat.zero_le]
+      | inr bytes =>
+          rw [signingBoundaryTrace_hashCalls_eq]
+          by_cases hs : segment.Selects (.inr bytes) <;> simp only [if_pos hs, if_neg hs, if_true, Nat.zero_le, le_refl]
+  }
+  rw [visibleGame, visible_counted_program] at hresult
+  exact CausalFrontierProgram.TraceCharge.game_counted_le charge outside ftsSecret words frontier adversary result
+    (QueryCap.simulate_oracle_mem_support _ _ result hresult)
+
+theorem visibleSeedGame_counted_le (segment : OtsPrefix) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs) (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+    (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph) (secrets : OtsFrontierValues)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (adversary : Adversary) (endpoint : Digest)
+    (result : (Bool × SigningBoundaryTrace) × Nat)
+    (hresult : result ∈ support (QueryCap.counted IsPrefixQuery
+      (segment.visibleSeedGame inputs hencoding hgraph auxiliary secrets ftsSecret words adversary endpoint))) :
+    result.2 ≤ result.1.2.hashCalls :=
+  segment.visibleGame_counted_le auxiliary.high _ ftsSecret words _ adversary result hresult
+
+end SphincsSecurity.Concrete.OtsPrefix
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixVisibleCompletion.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixVisibleCompletion.lean
new file mode 100644
index 000000000..32e514f98
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixVisibleCompletion.lean
@@ -0,0 +1,46 @@
+import SphincsSecurity.Proof.Ots.OtsPrefixVisibleContact
+import SphincsSecurity.Proof.Base.QueryTraceInvariant
+namespace SphincsSecurity.Concrete.OtsPrefix
+
+open _root_.OracleComp OracleSpec PartialChainEndpoint
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+
+theorem visible_traced_contact (segment : OtsPrefix) (high : segment.Query → High) (auxiliary : QueryImpl OracleWorld PMF)
+    (endpoint : Digest) {Result : Type} (computation : OracleComp OracleWorld Result) (history : OtsContactTrace.Trace)
+    (observed : Fin segment.digit.val → Digest → Option Digest)
+    (hseen : OtsContactTrace.Seen segment endpoint history ↔ Contact observed endpoint)
+    (result : (Result × OtsContactTrace.Trace) × (Fin segment.digit.val → Digest → Option Digest))
+    (hresult : result ∈ (lazyRun auxiliary (QueryPause.traced (segment.visibleObservationTrace high)
+      (simulateQ (segment.visibleWorldImpl high) computation)) observed).support) :
+    OtsContactTrace.Seen segment endpoint (history * result.1.2) ↔ Contact result.2 endpoint := by
+  have htrace : QueryPause.traced (segment.visibleObservationTrace high) (simulateQ (segment.visibleWorldImpl high) computation) =
+      simulateQ (segment.visibleWorldImpl high) (QueryPause.traced hashObservationTrace computation) :=
+    segment.visible_observation_program high computation
+  rw [htrace, lazyRun, ← QueryImpl.simulateQ_compose] at hresult
+  apply QueryPause.traced_simulation_invariant hashObservationTrace (segment.visibleLazyImpl high auxiliary)
+    (fun trace rows => OtsContactTrace.Seen segment endpoint trace ↔ Contact rows endpoint) _
+    computation history observed hseen result hresult
+  intro trace rows hrows input answer hanswer
+  exact segment.visible_step_contact high auxiliary endpoint trace rows hrows input answer hanswer
+
+theorem visible_traced_queries_le (segment : OtsPrefix) (high : segment.Query → High)
+    {Result : Type} (computation : OracleComp segment.VisibleWorld Result)
+    (result : (Result × OtsContactTrace.Trace) × Nat)
+    (hresult : result ∈ support (QueryCap.counted IsPrefixQuery (QueryPause.traced (segment.visibleObservationTrace high) computation))) :
+    result.2 ≤ OtsContactTrace.prefixCalls segment result.1.2 := by
+  apply QueryPause.traced_counted_le (segment.visibleObservationTrace high) IsPrefixQuery (OtsContactTrace.prefixCalls segment)
+    (OtsContactTrace.prefixCalls_mul segment) _ computation result hresult
+  intro input answer
+  cases input with
+  | inl input => simp only [IsPrefixQuery, if_false, Nat.zero_le]
+  | inr query =>
+      have hs : segment.Selects (.inr (segment.input query)) := by
+        change segment.parse (segment.input query) ≠ none
+        rw [parse_input]
+        exact Option.some_ne_none query
+      have h := OtsContactTrace.prefixCalls_step segment (.inr (segment.input query)) (combine answer (high query)) 1
+      simpa only [hashObservationTrace, visibleObservationTrace, mul_one, if_pos hs,
+        OtsContactTrace.prefixCalls_one, Nat.add_zero, IsPrefixQuery, if_true] using le_of_eq h.symm
+
+end SphincsSecurity.Concrete.OtsPrefix
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixVisibleContact.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixVisibleContact.lean
new file mode 100644
index 000000000..3f71211d9
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixVisibleContact.lean
@@ -0,0 +1,128 @@
+import SphincsSecurity.Proof.Ots.OtsContactAllocation
+import SphincsSecurity.Proof.Chains.PartialChainLastRow
+namespace SphincsSecurity.Concrete.OtsPrefix
+
+open _root_.OracleComp OracleSpec PartialChainEndpoint
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+
+private theorem contact_record_consistent {State : Type} [DecidableEq State] {n : Nat}
+    (observed : Fin n → State → Option State) (query : Fin n × State) (answer endpoint : State)
+    (hconsistent : observed query.1 query.2 = none ∨ observed query.1 query.2 = some answer) :
+    Contact (record observed query answer) endpoint ↔ Contact observed endpoint ∨ query.1.val + 1 = n ∧ answer = endpoint := by
+  by_cases hc : Contact observed endpoint
+  · exact iff_of_true (contact_mono (record_extends observed query answer hconsistent) endpoint hc) (Or.inl hc)
+  · simpa only [hc, false_or] using contact_record_iff observed query answer endpoint hc
+
+noncomputable def visibleLazyImpl (segment : OtsPrefix) (high : segment.Query → High) (auxiliary : QueryImpl OracleWorld PMF) :
+    QueryImpl OracleWorld (StateT (Fin segment.digit.val → Digest → Option Digest) PMF) :=
+  (lazyImpl auxiliary).compose (segment.visibleWorldImpl high)
+
+theorem visible_step_contact (segment : OtsPrefix) (high : segment.Query → High) (auxiliary : QueryImpl OracleWorld PMF)
+    (endpoint : Digest) (trace : OtsContactTrace.Trace) (observed : Fin segment.digit.val → Digest → Option Digest)
+    (hseen : OtsContactTrace.Seen segment endpoint trace ↔ Contact observed endpoint)
+    (input : OracleWorld.Domain) (result : OracleWorld.Range input × (Fin segment.digit.val → Digest → Option Digest))
+    (hresult : result ∈ ((segment.visibleLazyImpl high auxiliary input).run observed).support) :
+    OtsContactTrace.Seen segment endpoint (trace * hashObservationTrace input result.1) ↔ Contact result.2 endpoint := by
+  cases input with
+  | inl input =>
+      simp only [visibleLazyImpl, QueryImpl.apply_compose, visibleWorldImpl, simulateQ_spec_query,
+        lazyImpl, StateT.run_mk, PMF.mem_support_map_iff] at hresult
+      obtain ⟨answer, _, rfl⟩ := hresult
+      simpa only [hashObservationTrace, mul_one] using hseen
+  | inr bytes =>
+      cases hparse : segment.parse bytes with
+      | none =>
+          simp only [visibleLazyImpl, QueryImpl.apply_compose, visibleWorldImpl, visibleHashImpl, hparse,
+            simulateQ_spec_query, lazyImpl, StateT.run_mk, PMF.mem_support_map_iff] at hresult
+          obtain ⟨answer, _, rfl⟩ := hresult
+          simpa only [hashObservationTrace, OtsContactTrace.seen_mul, OtsContactTrace.seen_of,
+            OtsContactTrace.EntryContact, hparse, reduceCtorEq, false_and, exists_false, or_false] using hseen
+      | some query =>
+          have hbytes := (segment.parse_some_iff bytes query).mp hparse
+          subst bytes
+          simp only [visibleLazyImpl, QueryImpl.apply_compose, visibleWorldImpl, visibleHashImpl, parse_input,
+            simulateQ_map, simulateQ_spec_query, lazyImpl, StateT.run_map, StateT.run_mk,
+            PMF.monad_map_eq_map, PMF.map_comp, Function.comp_def, PMF.mem_support_map_iff] at hresult
+          obtain ⟨answer, hanswer, rfl⟩ := hresult
+          have hconsistent : observed query.1 query.2 = none ∨ observed query.1 query.2 = some answer := by
+            cases hrow : observed query.1 query.2 with
+            | none => exact Or.inl rfl
+            | some old =>
+                rw [hrow, rowLaw, PMF.mem_support_pure_iff] at hanswer
+                exact Or.inr (congrArg some hanswer.symm)
+          rw [hashObservationTrace, OtsContactTrace.seen_mul, OtsContactTrace.seen_of, hseen,
+            contact_record_consistent observed query answer endpoint hconsistent]
+          simp only [OtsContactTrace.EntryContact, parse_input, Option.some.injEq, truncate_combine]
+          apply or_congr Iff.rfl
+          constructor
+          · rintro ⟨other, rfl, h⟩; exact h
+          · intro h; exact ⟨query, rfl, h⟩
+
+theorem visible_pause_contact (segment : OtsPrefix) (high : segment.Query → High) (auxiliary : QueryImpl OracleWorld PMF)
+    (endpoint : Digest) (stop : OtsContactTrace.Trace → Prop) [DecidablePred stop]
+    {Result : Type} (computation : OracleComp OracleWorld Result) (trace : OtsContactTrace.Trace)
+    (observed : Fin segment.digit.val → Digest → Option Digest)
+    (hseen : OtsContactTrace.Seen segment endpoint trace ↔ Contact observed endpoint)
+    (result : (OtsContactTrace.Trace × OracleComp OracleWorld Result) × (Fin segment.digit.val → Digest → Option Digest))
+    (hresult : result ∈ ((simulateQ (segment.visibleLazyImpl high auxiliary)
+      (QueryPause.run stop (fun input answer history => history * hashObservationTrace input answer) computation trace)).run observed).support) :
+    OtsContactTrace.Seen segment endpoint result.1.1 ↔ Contact result.2 endpoint := by
+  apply QueryPause.run_simulation_invariant stop _ (segment.visibleLazyImpl high auxiliary)
+    (fun history rows => OtsContactTrace.Seen segment endpoint history ↔ Contact rows endpoint) _
+    computation trace observed hseen result hresult
+  intro history rows hrows _ input answer hanswer
+  exact segment.visible_step_contact high auxiliary endpoint history rows hrows input answer hanswer
+
+theorem visible_step_queryCount (segment : OtsPrefix) (high : segment.Query → High) (auxiliary : QueryImpl OracleWorld PMF)
+    (trace : OtsContactTrace.Trace) (observed : Fin segment.digit.val → Digest → Option Digest)
+    (hcount : queryCount observed ≤ OtsContactTrace.prefixCalls segment trace)
+    (input : OracleWorld.Domain) (result : OracleWorld.Range input × (Fin segment.digit.val → Digest → Option Digest))
+    (hresult : result ∈ ((segment.visibleLazyImpl high auxiliary input).run observed).support) :
+    queryCount result.2 ≤ OtsContactTrace.prefixCalls segment (trace * hashObservationTrace input result.1) := by
+  cases input with
+  | inl input =>
+      simp only [visibleLazyImpl, QueryImpl.apply_compose, visibleWorldImpl, simulateQ_spec_query,
+        lazyImpl, StateT.run_mk, PMF.mem_support_map_iff] at hresult
+      obtain ⟨answer, _, rfl⟩ := hresult
+      simpa only [hashObservationTrace, mul_one] using hcount
+  | inr bytes =>
+      cases hparse : segment.parse bytes with
+      | none =>
+          simp only [visibleLazyImpl, QueryImpl.apply_compose, visibleWorldImpl, visibleHashImpl, hparse,
+            simulateQ_spec_query, lazyImpl, StateT.run_mk, PMF.mem_support_map_iff] at hresult
+          obtain ⟨answer, _, rfl⟩ := hresult
+          rw [OtsContactTrace.prefixCalls_mul]
+          exact hcount.trans (Nat.le_add_right _ _)
+      | some query =>
+          have hbytes := (segment.parse_some_iff bytes query).mp hparse
+          subst bytes
+          simp only [visibleLazyImpl, QueryImpl.apply_compose, visibleWorldImpl, visibleHashImpl, parse_input,
+            simulateQ_map, simulateQ_spec_query, lazyImpl, StateT.run_map, StateT.run_mk,
+            PMF.monad_map_eq_map, PMF.map_comp, Function.comp_def, PMF.mem_support_map_iff] at hresult
+          obtain ⟨answer, _, rfl⟩ := hresult
+          have hselected : segment.Selects (.inr (segment.input query)) := by
+            change segment.parse (segment.input query) ≠ none
+            rw [parse_input]
+            exact Option.some_ne_none query
+          have hsingle := OtsContactTrace.prefixCalls_step segment (.inr (segment.input query)) (combine answer (high query)) 1
+          simp only [mul_one, if_pos hselected, OtsContactTrace.prefixCalls_one, Nat.add_zero] at hsingle
+          rw [OtsContactTrace.prefixCalls_mul, hsingle]
+          exact (queryCount_record_le observed query answer).trans (Nat.add_le_add_right hcount 1)
+
+theorem visible_pause_queryCount (segment : OtsPrefix) (high : segment.Query → High) (auxiliary : QueryImpl OracleWorld PMF)
+    (stop : OtsContactTrace.Trace → Prop) [DecidablePred stop]
+    {Result : Type} (computation : OracleComp OracleWorld Result) (trace : OtsContactTrace.Trace)
+    (observed : Fin segment.digit.val → Digest → Option Digest)
+    (hcount : queryCount observed ≤ OtsContactTrace.prefixCalls segment trace)
+    (result : (OtsContactTrace.Trace × OracleComp OracleWorld Result) × (Fin segment.digit.val → Digest → Option Digest))
+    (hresult : result ∈ ((simulateQ (segment.visibleLazyImpl high auxiliary)
+      (QueryPause.run stop (fun input answer history => history * hashObservationTrace input answer) computation trace)).run observed).support) :
+    queryCount result.2 ≤ OtsContactTrace.prefixCalls segment result.1.1 := by
+  apply QueryPause.run_simulation_invariant stop _ (segment.visibleLazyImpl high auxiliary)
+    (fun history rows => queryCount rows ≤ OtsContactTrace.prefixCalls segment history) _
+    computation trace observed hcount result hresult
+  intro history rows hrows _ input answer hanswer
+  exact segment.visible_step_queryCount high auxiliary history rows hrows input answer hanswer
+
+end SphincsSecurity.Concrete.OtsPrefix
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixVisibleTrace.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixVisibleTrace.lean
new file mode 100644
index 000000000..0837ded4a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsPrefixVisibleTrace.lean
@@ -0,0 +1,128 @@
+import SphincsSecurity.Proof.Ots.OtsPrefixVisible
+import SphincsSecurity.Proof.Base.QueryPause
+
+/-! ## QueryPauseTranslation -/
+
+namespace SphincsSecurity.QueryPause
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {Source Target Memory Result : Type} {source : OracleSpec Source} {target : OracleSpec Target}
+
+theorem run_translation (stop : Memory → Prop) [DecidablePred stop]
+    (sourceStep : (input : source.Domain) → source.Range input → Memory → Memory)
+    (targetStep : (input : target.Domain) → target.Range input → Memory → Memory)
+    (queryMap : source.Domain → target.Domain)
+    (answerMap : (input : source.Domain) → target.Range (queryMap input) → source.Range input)
+    (impl : QueryImpl source (OracleComp target))
+    (himpl : ∀ input, impl input = answerMap input <$> liftM (target.query (queryMap input)))
+    (hstep : ∀ input answer memory, targetStep (queryMap input) answer memory = sourceStep input (answerMap input answer) memory)
+    (computation : OracleComp source Result) (memory : Memory) :
+    run stop targetStep (simulateQ impl computation) memory =
+      (fun paused => (paused.1, simulateQ impl paused.2)) <$> simulateQ impl (run stop sourceStep computation memory) := by
+  induction computation using OracleComp.inductionOn generalizing memory with
+  | pure result => simp only [simulateQ_pure, run_pure, map_pure]
+  | query_bind input next ih =>
+      simp only [simulateQ_bind, simulateQ_spec_query, himpl, bind_map_left, run_query_bind]
+      by_cases hs : stop memory
+      · simp only [if_pos hs, simulateQ_pure, map_pure, simulateQ_bind, simulateQ_spec_query, himpl, bind_map_left]
+      · simp only [if_neg hs, simulateQ_bind, simulateQ_spec_query, himpl, bind_map_left, map_bind, hstep, ih]
+
+end SphincsSecurity.QueryPause
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+def hashObservationTrace : (input : OracleWorld.Domain) → OracleWorld.Range input → FreeMonoid (HashInput × HashOutput)
+  | .inl _, _ => 1
+  | .inr input, answer => FreeMonoid.of (input, answer)
+
+namespace OtsPrefix
+
+noncomputable def visibleObservationTrace (segment : OtsPrefix) (high : segment.Query → High) :
+    (input : segment.VisibleWorld.Domain) → segment.VisibleWorld.Range input → FreeMonoid (HashInput × HashOutput)
+  | .inl input, answer => hashObservationTrace input answer
+  | .inr query, answer => FreeMonoid.of (segment.input query, combine answer (high query))
+
+private theorem withTrace_run {Input Target Trace : Type} {spec : OracleSpec Input} {target : OracleSpec Target} [Monoid Trace]
+    (impl : QueryImpl spec (OracleComp target)) (trace : (input : spec.Domain) → spec.Range input → Trace) (input : spec.Domain) :
+    (impl.withTrace trace input).run = (fun answer => (answer, trace input answer)) <$> impl input := by
+  simp [QueryImpl.withTrace_apply, WriterT.run_bind, WriterT.run_tell]
+
+theorem visible_observation_step (segment : OtsPrefix) (high : segment.Query → High) (input : OracleWorld.Domain) :
+    (simulateQ ((QueryImpl.id' segment.VisibleWorld).withTrace (segment.visibleObservationTrace high))
+      (segment.visibleWorldImpl high input)).run =
+        ((segment.visibleWorldImpl high).withTrace hashObservationTrace input).run := by
+  cases input with
+  | inl input =>
+      simp only [visibleWorldImpl, simulateQ_spec_query, withTrace_run, visibleObservationTrace, hashObservationTrace]
+      rfl
+  | inr bytes =>
+      cases hparse : segment.parse bytes with
+      | none =>
+          simp only [visibleWorldImpl, visibleHashImpl, hparse, simulateQ_spec_query, withTrace_run,
+            visibleObservationTrace, hashObservationTrace]
+          rfl
+      | some query =>
+          have hbytes := (segment.parse_some_iff bytes query).mp hparse
+          subst bytes
+          simp only [visibleWorldImpl, visibleHashImpl, parse_input, simulateQ_map, simulateQ_spec_query, WriterT.run_map,
+            withTrace_run, visibleObservationTrace, hashObservationTrace, Functor.map_map]
+          rfl
+
+theorem visible_observation_program (segment : OtsPrefix) (high : segment.Query → High)
+    {Result : Type} (computation : OracleComp OracleWorld Result) :
+    (simulateQ ((QueryImpl.id' segment.VisibleWorld).withTrace (segment.visibleObservationTrace high))
+      (simulateQ (segment.visibleWorldImpl high) computation)).run =
+    simulateQ (segment.visibleWorldImpl high)
+      ((simulateQ ((QueryImpl.id' OracleWorld).withTrace hashObservationTrace) computation).run) := by
+  rw [← QueryImpl.simulateQ_compose]
+  symm
+  apply simulateQ_writer_compose
+  intro input
+  rw [QueryImpl.apply_compose, visible_observation_step, withTrace_run, withTrace_run, simulateQ_map]
+  change (fun answer => (answer, hashObservationTrace input answer)) <$>
+    simulateQ (segment.visibleWorldImpl high) (liftM (OracleWorld.query input)) = _
+  rw [simulateQ_spec_query]
+
+theorem visible_pause_program (segment : OtsPrefix) (high : segment.Query → High)
+    (stop : FreeMonoid (HashInput × HashOutput) → Prop) [DecidablePred stop]
+    {Result : Type} (computation : OracleComp OracleWorld Result) (trace : FreeMonoid (HashInput × HashOutput)) :
+    QueryPause.run stop (fun input answer history => history * segment.visibleObservationTrace high input answer)
+      (simulateQ (segment.visibleWorldImpl high) computation) trace =
+    (fun paused => (paused.1, simulateQ (segment.visibleWorldImpl high) paused.2)) <$>
+      simulateQ (segment.visibleWorldImpl high)
+        (QueryPause.run stop (fun input answer history => history * hashObservationTrace input answer) computation trace) := by
+  classical
+  have htranslation (input : OracleWorld.Domain) : ∃ (query : segment.VisibleWorld.Domain)
+      (decode : segment.VisibleWorld.Range query → OracleWorld.Range input),
+      segment.visibleWorldImpl high input = decode <$> liftM (segment.VisibleWorld.query query) ∧
+        ∀ answer (history : FreeMonoid (HashInput × HashOutput)),
+          history * segment.visibleObservationTrace high query answer = history * hashObservationTrace input (decode answer) := by
+    cases input with
+    | inl input =>
+        refine ⟨.inl (.inl input), id, ?_, ?_⟩
+        · simp only [visibleWorldImpl, id_map]
+        · intro answer history; rfl
+    | inr bytes =>
+        cases hparse : segment.parse bytes with
+        | none =>
+            refine ⟨.inl (.inr bytes), id, ?_, ?_⟩
+            · simp only [visibleWorldImpl, visibleHashImpl, hparse, id_map]
+            · intro answer history; rfl
+        | some query =>
+            refine ⟨.inr query, fun answer => combine answer (high query), ?_, ?_⟩
+            · simp only [visibleWorldImpl, visibleHashImpl, hparse]
+              rfl
+            · intro answer history
+              simp only [visibleObservationTrace, hashObservationTrace, (segment.parse_some_iff bytes query).mp hparse]
+  exact QueryPause.run_translation stop _ _ (fun input => (htranslation input).choose)
+    (fun input => (htranslation input).choose_spec.choose) (segment.visibleWorldImpl high)
+    (fun input => (htranslation input).choose_spec.choose_spec.1)
+    (fun input => (htranslation input).choose_spec.choose_spec.2) computation trace
+
+end OtsPrefix
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsProbeCanonicalChargeGame.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsProbeCanonicalChargeGame.lean
new file mode 100644
index 000000000..ac4057c10
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsProbeCanonicalChargeGame.lean
@@ -0,0 +1,49 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Ots.EncodingSelectionCache
+import SphincsSecurity.Proof.Ots.OtsProbeOrigin
+import SphincsSecurity.Proof.Fts.FtsProbeSampling
+import SphincsSecurity.Proof.Base.RomQueryChargeBind
+namespace SphincsSecurity
+
+open OracleComp OracleSpec ENNReal
+
+theorem expectedQueryCharge_map
+    (charge : QueryCache HashSpec → HashInput → ℝ≥0∞)
+    (computation : OracleComp OracleWorld α) (f : α → β) (cache : QueryCache HashSpec) :
+    expectedQueryCharge charge (f <$> computation) cache = expectedQueryCharge charge computation cache := by
+  rw [map_eq_bind_pure_comp, expectedQueryCharge_bind]
+  simp only [Function.comp_apply, expectedQueryCharge_pure, mul_zero, tsum_zero, add_zero]
+
+namespace Concrete.OtsProbeSimulation
+
+theorem gameRest_eq_map_retained
+    (adversary : Adversary) (secretKey : SecretKey) (publicKey : PublicKey) :
+    gameRest scheme adversary publicKey secretKey =
+      (fun result : RetainedRestResult =>
+        decide (SigningTranscript.Valid result.1.2 ∧ ¬SigningTranscript.Contains result.1.2 result.1.1) && result.2) <$>
+        simulateQ (expandedAdversaryImpl secretKey) (retainedGameRestComputation adversary publicKey) := by
+  unfold gameRest retainedGameRestComputation
+  rw [simulateQ_bind, ← simulateQ_withTraceAppend_run_eq_signingTraceComputation,
+    ← forwardOracles_add_signingOracle_eq_withTraceAppend, map_bind]
+  apply bind_congr
+  intro result
+  rcases result with ⟨forgery, log⟩
+  rw [simulateQ_bind]
+  have hlift : simulateQ (expandedAdversaryImpl secretKey)
+      (liftOracleWorldLeft (scheme.verify publicKey forgery.message forgery.signature)) =
+      scheme.verify publicKey forgery.message forgery.signature :=
+    FtsProbeSimulation.simulateQ_expanded_liftOracleWorldLeft secretKey _
+  rw [hlift]
+  simp only [simulateQ_pure, map_bind, map_pure]
+
+theorem expectedQueryCharge_retained_eq_gameRest
+    (adversary : Adversary) (secretKey : SecretKey) (publicKey : PublicKey)
+    (charge : QueryCache HashSpec → HashInput → ℝ≥0∞) (cache : QueryCache HashSpec) :
+    expectedQueryCharge charge (simulateQ (expandedAdversaryImpl secretKey)
+      (retainedGameRestComputation adversary publicKey)) cache =
+      expectedQueryCharge charge (gameRest scheme adversary publicKey secretKey) cache := by
+  rw [gameRest_eq_map_retained, expectedQueryCharge_map]
+
+end Concrete.OtsProbeSimulation
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsProbeCompletionSampling.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsProbeCompletionSampling.lean
new file mode 100644
index 000000000..4d8ae56fe
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsProbeCompletionSampling.lean
@@ -0,0 +1,25 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FtsProbeSimulation
+import SphincsSecurity.Proof.Ots.OtsProbeSimulation
+/-!
+# 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
+
+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]
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsProbeOrigin.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsProbeOrigin.lean
new file mode 100644
index 000000000..9aad50023
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsProbeOrigin.lean
@@ -0,0 +1,28 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FtsProbeOrigin
+import SphincsSecurity.Proof.Ots.OtsProbeSimulation
+/-!
+# 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
+
+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]
+
+end SphincsSecurity.Concrete.OtsProbeSimulation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsProbeSimulation.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsProbeSimulation.lean
new file mode 100644
index 000000000..df09e509e
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsProbeSimulation.lean
@@ -0,0 +1,66 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Scheme.ForgeryClassify
+import SphincsSecurity.Proof.Ots.SecretProbe
+import SphincsSecurity.Proof.Reference.SigningTrace
+/-!
+# 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)
+
+abbrev RetainedRestResult := (Forgery × QueryLog SigningSpec) × Bool
+
+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
+
+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)
+
+end SphincsSecurity.Concrete.OtsProbeSimulation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTraceCheckpointBudget.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTraceCheckpointBudget.lean
new file mode 100644
index 000000000..f7a22fc75
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTraceCheckpointBudget.lean
@@ -0,0 +1,50 @@
+import SphincsSecurity.Proof.Ots.OtsTraceCheckpointLaw
+import SphincsSecurity.Proof.Ots.OtsPrefixVisibleAccounting
+import SphincsSecurity.Proof.Chains.AdaptiveChainActualBudget
+import SphincsSecurity.Proof.Base.QueryTraceInvariant
+namespace SphincsSecurity.Concrete.OtsPrefix
+
+open _root_.OracleComp OracleSpec PartialChainEndpoint
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+variable (segment : OtsPrefix) (stop : FrontierStop)
+  [∀ parameter words frontier, DecidablePred (stop parameter words frontier)] (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs) (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+  (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph) (secrets : OtsFrontierValues)
+  (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (adversary : Adversary)
+
+theorem traceCheckpoint_budget (budget : Nat)
+    (hreal : ∀ result ∈ (realRun (fun _ => uniformImpl)
+      (fun endpoint => segment.seedGame inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary) (fun _ _ => none)).support,
+      result.2.1.2.hashCalls ≤ budget)
+    (hsmall : budget < Fintype.card Digest) (endpoint : Digest)
+    (middle : ((OtsContactTrace.Trace × OracleComp segment.VisibleWorld (Bool × SigningBoundaryTrace)) × Nat) ×
+      (Fin segment.digit.val → Digest → Option Digest))
+    (hmiddle : middle ∈ (lazyRun (extendAux uniformImpl (segment.seedOracle inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint))
+      (segment.traceCheckpointBefore stop inputs hencoding hgraph auxiliary secrets ftsSecret words adversary endpoint) (fun _ _ => none)).support)
+    (result : (((Bool × SigningBoundaryTrace) × OtsContactTrace.Trace) × Nat) × (Fin segment.digit.val → Digest → Option Digest))
+    (hresult : result ∈ (lazyRun (extendAux uniformImpl (segment.seedOracle inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint))
+      (QueryCap.counted IsPrefixQuery (QueryPause.traced (segment.visibleObservationTrace auxiliary.high) middle.1.1.2)) middle.2).support) :
+    queryCount middle.2 + result.1.2 ≤ budget ∧ queryCount result.2 ≤ budget := by
+  let aux := fun endpoint => extendAux uniformImpl (segment.seedOracle inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint)
+  let program := segment.visibleSeedGame inputs hencoding hgraph auxiliary secrets ftsSecret words adversary
+  have hreal' : ∀ result ∈ (realRun aux program (fun _ _ => none)).support, result.2.1.2.hashCalls ≤ budget := by
+    rw [segment.visibleSeedGame_real inputs hencoding hgraph auxiliary secrets ftsSecret words adversary]
+    exact hreal
+  have hresult' : ((result.1.1.1, result.1.2), result.2) ∈
+      (lazyRun (aux endpoint) (QueryCap.counted IsPrefixQuery middle.1.1.2) middle.2).support := by
+    have hforget := congrArg (fun computation => lazyRun (aux endpoint) computation middle.2)
+      (QueryPause.traced_counted_forget (segment.visibleObservationTrace auxiliary.high) IsPrefixQuery middle.1.1.2)
+    rw [lazyRun_map] at hforget
+    rw [← hforget, PMF.mem_support_map_iff]
+    exact ⟨result, hresult, rfl⟩
+  exact lazyRun_pause_budget_of_real aux program (fun output => output.2.hashCalls) budget
+    (fun endpoint output houtput => segment.visibleSeedGame_counted_le inputs hencoding hgraph auxiliary secrets ftsSecret words adversary endpoint output houtput)
+    hreal' hsmall endpoint
+    (stop segment.parameter words (segment.seedFrontier inputs hencoding hgraph auxiliary secrets words endpoint))
+    (fun input answer history => history * segment.visibleObservationTrace auxiliary.high input answer)
+    1 middle hmiddle ((result.1.1.1, result.1.2), result.2) hresult'
+
+end SphincsSecurity.Concrete.OtsPrefix
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTraceCheckpointLaw.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTraceCheckpointLaw.lean
new file mode 100644
index 000000000..8f8ac05a2
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTraceCheckpointLaw.lean
@@ -0,0 +1,89 @@
+import SphincsSecurity.Proof.Ots.OtsContactCheckpoint
+import SphincsSecurity.Proof.Chains.AdaptiveChainCheckpointProjection
+import SphincsSecurity.Proof.Ots.OtsPrefixInstrumentedVisible
+import SphincsSecurity.Proof.Ots.TraceCheckpointObserver
+namespace SphincsSecurity.Concrete.OtsPrefix
+
+open _root_.OracleComp OracleSpec PartialChainEndpoint
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+theorem visible_checkpoint_program (segment : OtsPrefix) (stop : FrontierStop)
+    [∀ parameter words frontier, DecidablePred (stop parameter words frontier)] (high : segment.Query → High)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) {Result : Type} (computation : OracleComp OracleWorld Result) :
+    (do
+      let middle ← QueryPause.run (stop segment.parameter words frontier)
+        (fun input answer history => history * segment.visibleObservationTrace high input answer)
+        (simulateQ (segment.visibleWorldImpl high) computation) 1
+      let tail ← QueryPause.traced (segment.visibleObservationTrace high) middle.2
+      pure (middle.1, tail)) =
+    simulateQ (segment.visibleWorldImpl high) (checkpointSplitRun stop segment.parameter words frontier computation) := by
+  have htrace (program : OracleComp OracleWorld Result) :
+      QueryPause.traced (segment.visibleObservationTrace high) (simulateQ (segment.visibleWorldImpl high) program) =
+        simulateQ (segment.visibleWorldImpl high) (QueryPause.traced hashObservationTrace program) :=
+    segment.visible_observation_program high program
+  rw [visible_pause_program]
+  simp only [bind_map_left, htrace, checkpointSplitRun, simulateQ_bind, simulateQ_pure]
+
+variable (segment : OtsPrefix) (stop : FrontierStop)
+  [∀ parameter words frontier, DecidablePred (stop parameter words frontier)] (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs) (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+  (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph) (secrets : OtsFrontierValues)
+  (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (adversary : Adversary)
+
+noncomputable def traceCheckpointBefore (endpoint : Digest) :=
+  QueryCap.counted IsPrefixQuery (QueryPause.run
+    (stop segment.parameter words (segment.seedFrontier inputs hencoding hgraph auxiliary secrets words endpoint))
+    (fun input answer history => history * segment.visibleObservationTrace auxiliary.high input answer)
+    (segment.visibleSeedGame inputs hencoding hgraph auxiliary secrets ftsSecret words adversary endpoint) 1)
+
+noncomputable def traceCheckpointRun :=
+  realCheckpointRun (fun endpoint => extendAux uniformImpl
+    (segment.seedOracle inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint))
+    (segment.traceCheckpointBefore stop inputs hencoding hgraph auxiliary secrets ftsSecret words adversary)
+    (fun _ middle => QueryPause.traced (segment.visibleObservationTrace auxiliary.high) middle.1.1.2) (fun _ _ => none)
+
+theorem traceCheckpointRun_project :
+    (segment.traceCheckpointRun stop inputs hencoding hgraph auxiliary secrets ftsSecret words adversary).map
+      (fun result => (result.1,
+        (⟨segment.seedFrontier inputs hencoding hgraph auxiliary secrets words result.1,
+          result.2.1.1.1.1, result.2.2.1.1.1, result.2.2.1.1.2⟩ : ContactResult), result.2.2.2)) =
+    realRun (fun _ => uniformImpl)
+      (fun endpoint => segment.instrumentedSeedGame (checkpointObserver stop) inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+      (fun _ _ => none) := by
+  rw [traceCheckpointRun]
+  rw [realCheckpointRun_project
+    (fun endpoint => extendAux uniformImpl (segment.seedOracle inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint))
+    (segment.traceCheckpointBefore stop inputs hencoding hgraph auxiliary secrets ftsSecret words adversary)
+    (fun _ middle => QueryPause.traced (segment.visibleObservationTrace auxiliary.high) middle.1.2)
+    (fun _ _ => none)
+    (fun endpoint middle tail => (⟨segment.seedFrontier inputs hencoding hgraph auxiliary secrets words endpoint,
+      middle.1.1, tail.1, tail.2⟩ : ContactResult))]
+  rw [← segment.visibleInstrumentedSeedGame_real (checkpointObserver stop) inputs hencoding hgraph auxiliary secrets ftsSecret words adversary]
+  congr 1
+  funext endpoint
+  let frontier := segment.seedFrontier inputs hencoding hgraph auxiliary secrets words endpoint
+  let program := CausalFrontierProgram.game segment.parameter
+    (segment.seedOracle inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint) ftsSecret words frontier adversary
+  let paused := QueryPause.run (stop segment.parameter words frontier)
+    (fun input answer history => history * segment.visibleObservationTrace auxiliary.high input answer)
+    (simulateQ (segment.visibleWorldImpl auxiliary.high) program) 1
+  let finish := fun middle : OtsContactTrace.Trace × OracleComp segment.VisibleWorld (Bool × SigningBoundaryTrace) => do
+    let tail ← QueryPause.traced (segment.visibleObservationTrace auxiliary.high) middle.2
+    pure (⟨frontier, middle.1, tail.1, tail.2⟩ : ContactResult)
+  change (QueryCap.counted IsPrefixQuery paused >>= fun middle => finish middle.1) = _
+  have hforget := congrArg (fun computation => computation >>= finish) (QueryCap.counted_forget IsPrefixQuery paused)
+  rw [bind_map_left] at hforget
+  rw [hforget]
+  have hmap : (paused >>= finish) = (fun result => (⟨frontier, result.1, result.2.1, result.2.2⟩ : ContactResult)) <$>
+      (do let middle ← paused; let tail ← QueryPause.traced (segment.visibleObservationTrace auxiliary.high) middle.2; pure (middle.1, tail)) := by
+    simp only [map_bind, map_pure, finish]
+  rw [hmap]
+  rw [show (do let middle ← paused; let tail ← QueryPause.traced (segment.visibleObservationTrace auxiliary.high) middle.2; pure (middle.1, tail)) =
+      simulateQ (segment.visibleWorldImpl auxiliary.high) (checkpointSplitRun stop segment.parameter words frontier program) from
+        segment.visible_checkpoint_program stop auxiliary.high words frontier program]
+  rw [← simulateQ_map]
+  rfl
+
+end SphincsSecurity.Concrete.OtsPrefix
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTraceCheckpointObservation.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTraceCheckpointObservation.lean
new file mode 100644
index 000000000..6acfb6b49
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTraceCheckpointObservation.lean
@@ -0,0 +1,37 @@
+import SphincsSecurity.Proof.Ots.OtsTraceCheckpointLaw
+import SphincsSecurity.Proof.Ots.OtsPrefixCheckpointCompletion
+namespace SphincsSecurity.Concrete.OtsPrefix
+
+open _root_.OracleComp OracleSpec PartialChainEndpoint
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+
+abbrev TraceCheckpointResult (segment : OtsPrefix) :=
+  Digest × (((OtsContactTrace.Trace × OracleComp segment.VisibleWorld (Bool × SigningBoundaryTrace)) × Nat) ×
+    (Fin segment.digit.val → Digest → Option Digest)) ×
+    ((((Bool × SigningBoundaryTrace) × OtsContactTrace.Trace) × Nat) × (Fin segment.digit.val → Digest → Option Digest))
+
+variable (segment : OtsPrefix) (stop : FrontierStop)
+  [∀ parameter words frontier, DecidablePred (stop parameter words frontier)] (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs) (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+  (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph) (secrets : OtsFrontierValues)
+  (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (adversary : Adversary)
+
+theorem traceCheckpointRun_observation (result : segment.TraceCheckpointResult)
+    (hresult : result ∈ (segment.traceCheckpointRun stop inputs hencoding hgraph auxiliary secrets ftsSecret words adversary).support) :
+    (OtsContactTrace.Seen segment result.1 result.2.1.1.1.1 ↔ Contact result.2.1.2 result.1) ∧
+    (OtsContactTrace.Seen segment result.1 (result.2.1.1.1.1 * result.2.2.1.1.2) ↔ Contact result.2.2.2 result.1) ∧
+    queryCount result.2.1.2 ≤ OtsContactTrace.prefixCalls segment result.2.1.1.1.1 ∧
+    result.2.2.1.2 ≤ OtsContactTrace.prefixCalls segment result.2.2.1.1.2 := by
+  have hs := realCheckpointRun_support
+    (fun endpoint => extendAux uniformImpl (segment.seedOracle inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint))
+    (segment.traceCheckpointBefore stop inputs hencoding hgraph auxiliary secrets ftsSecret words adversary)
+    (fun _ middle => QueryPause.traced (segment.visibleObservationTrace auxiliary.high) middle.1.1.2) (fun _ _ => none) result hresult
+  exact segment.visible_checkpoint_observation auxiliary.high
+    (extendAux uniformImpl (segment.seedOracle inputs hencoding hgraph auxiliary secrets ftsSecret words result.1)) result.1
+    (stop segment.parameter words (segment.seedFrontier inputs hencoding hgraph auxiliary secrets words result.1))
+    (CausalFrontierProgram.game segment.parameter (segment.seedOracle inputs hencoding hgraph auxiliary secrets ftsSecret words result.1)
+      ftsSecret words (segment.seedFrontier inputs hencoding hgraph auxiliary secrets words result.1) adversary)
+    result.2.1 hs.1 result.2.2 hs.2
+
+end SphincsSecurity.Concrete.OtsPrefix
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTraceEvents.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTraceEvents.lean
new file mode 100644
index 000000000..e9ebee99b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTraceEvents.lean
@@ -0,0 +1,76 @@
+import SphincsSecurity.Proof.Ots.OtsTraceRestart
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec PartialChainEndpoint
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] OtsContactTrace.contacts canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+def ContactResult.ContactAfterStop (stop : FrontierStop) (parameter : PublicParameter) (words : OtsReferenceWords)
+    (address : OtsPrefix.ChainAddress) (result : ContactResult) : Prop :=
+  (stop parameter words result.frontier result.before ∧ address ∉ OtsContactTrace.contacts parameter words result.frontier result.before) ∧
+    address ∈ OtsContactTrace.contacts parameter words result.frontier (result.before * result.after)
+
+theorem ContactResult.contactAfterStop_eq_seen (stop : FrontierStop) (parameter : PublicParameter) (words : OtsReferenceWords)
+    (address : OtsPrefix.ChainAddress) (result : ContactResult) (endpoint : Digest)
+    (hendpoint : result.frontier address.1 address.2.1 address.2.2.1 address.2.2.2 = endpoint) :
+    result.ContactAfterStop stop parameter words address ↔
+      (stop parameter words result.frontier result.before ∧ ¬OtsContactTrace.Seen (OtsPrefix.atAddress parameter words address) endpoint result.before) ∧
+      OtsContactTrace.Seen (OtsPrefix.atAddress parameter words address) endpoint (result.before * result.after) := by
+  simp only [ContactAfterStop, OtsContactTrace.mem_contacts, hendpoint]
+
+theorem OtsPrefix.instrumentedCheckpoint_endpoint (segment : OtsPrefix) (stop : FrontierStop)
+    [∀ parameter words frontier, DecidablePred (stop parameter words frontier)] (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs) (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+    (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph) (secrets : OtsFrontierValues)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (adversary : Adversary)
+    (result : Digest × ContactResult × (Fin segment.digit.val → Digest → Option Digest))
+    (hresult : result ∈ (realRun (fun _ => OtsPrefix.uniformImpl)
+      (fun endpoint => segment.instrumentedSeedGame (checkpointObserver stop) inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+      (fun _ _ => none)).support) : result.2.1.frontier segment.lay segment.tree segment.leaf segment.chainIdx = result.1 := by
+  rw [← segment.traceCheckpointRun_project stop inputs hencoding hgraph auxiliary secrets ftsSecret words adversary,
+    PMF.mem_support_map_iff] at hresult
+  obtain ⟨checkpoint, _, rfl⟩ := hresult
+  simp only [OtsPrefix.seedFrontier, OtsPrefix.frontierFromEndpoint, OtsPrefix.replaceChain, OtsPrefix.SameChain,
+    and_self, if_true]
+
+theorem checkpointSeed_newContact_le_mark (stop : FrontierStop)
+    [∀ parameter words frontier, DecidablePred (stop parameter words frontier)]
+    (parameter : PublicParameter) (words : OtsReferenceWords) (address : OtsPrefix.ChainAddress)
+    (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (hgraph : canonicalGraphInputs parameter ⊆ inputs)
+    (auxiliary : (OtsPrefix.atAddress parameter words address).ReferenceAuxSeed inputs hencoding hgraph) (secrets : OtsFrontierValues)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (adversary : Adversary) (budget : Nat)
+    (hreal : ∀ result ∈ (realRun (fun _ => OtsPrefix.uniformImpl)
+      (fun endpoint => (OtsPrefix.atAddress parameter words address).seedGame inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+      (fun _ _ => none)).support, result.2.1.2.hashCalls ≤ budget)
+    (hsmall : budget < Fintype.card Digest) :
+    let segment := OtsPrefix.atAddress parameter words address
+    let law := realRun (fun _ => OtsPrefix.uniformImpl)
+      (fun endpoint => segment.instrumentedSeedGame (checkpointObserver stop) inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+      (fun _ _ => none)
+    (1 - (budget : ENNReal) / Fintype.card Digest) * ((Fintype.card Digest : ENNReal) *
+      Pr[fun result => result.2.1.ContactAfterStop stop parameter words address | law]) ≤
+      (2 * budget : Nat) * Pr[fun result => stop parameter words result.2.1.frontier result.2.1.before | law] := by
+  dsimp only
+  let segment := OtsPrefix.atAddress parameter words address
+  let law := realRun (fun _ => OtsPrefix.uniformImpl)
+    (fun endpoint => segment.instrumentedSeedGame (checkpointObserver stop) inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+    (fun _ _ => none)
+  have hevent : Pr[fun result => result.2.1.ContactAfterStop stop parameter words address | law] =
+      Pr[fun result => (stop parameter words result.2.1.frontier result.2.1.before ∧ ¬OtsContactTrace.Seen segment result.1 result.2.1.before) ∧
+        OtsContactTrace.Seen segment result.1 (result.2.1.before * result.2.1.after) | law] := by
+    simp only [probEvent_eq_tsum_ite, PMF.probOutput_eq_apply]
+    apply tsum_congr
+    intro result
+    by_cases hr : result ∈ law.support
+    · rw [ContactResult.contactAfterStop_eq_seen stop parameter words address result.2.1 result.1
+        (segment.instrumentedCheckpoint_endpoint stop inputs hencoding hgraph auxiliary secrets ftsSecret words adversary result hr)]
+      simp only [segment]
+    · have hz : law result = 0 := not_not.mp hr
+      simp only [hz, ite_self]
+  change (1 - (budget : ENNReal) / Fintype.card Digest) * ((Fintype.card Digest : ENNReal) *
+    Pr[fun result => result.2.1.ContactAfterStop stop parameter words address | law]) ≤ _
+  rw [hevent]
+  exact segment.instrumentedCheckpoint_newContact_le_mark stop inputs hencoding hgraph auxiliary secrets ftsSecret words adversary budget hreal hsmall
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTraceProbability.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTraceProbability.lean
new file mode 100644
index 000000000..08014fe9e
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTraceProbability.lean
@@ -0,0 +1,68 @@
+import SphincsSecurity.Proof.Ots.OtsTraceEvents
+import SphincsSecurity.Proof.Ots.OtsPrefixInstrumentedSource
+import SphincsSecurity.Proof.Ots.OtsPrefixObservedBudget
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+private theorem scaled_probability_bind_le {Value Left Right : Type} (law : SPMF Value)
+    (left : Value → SPMF Left) (right : Value → SPMF Right) (eventLeft : Left → Prop) (eventRight : Right → Prop)
+    (a b : ENNReal) (h : ∀ value ∈ support law, a * Pr[eventLeft | left value] ≤ b * Pr[eventRight | right value]) :
+    a * Pr[eventLeft | law >>= left] ≤ b * Pr[eventRight | law >>= right] := by
+  rw [probEvent_bind_eq_tsum, probEvent_bind_eq_tsum, ← ENNReal.tsum_mul_left, ← ENNReal.tsum_mul_left]
+  apply ENNReal.tsum_le_tsum
+  intro value
+  by_cases hv : value ∈ support law
+  · simpa only [mul_left_comm] using mul_le_mul' (le_refl (Pr[= value | law])) (h value hv)
+  · simp only [probOutput_eq_zero_of_not_mem_support hv, zero_mul, mul_zero, le_refl]
+
+private theorem probComp_mem_of_evalDist {Result : Type} (computation : ProbComp Result) (result : Result)
+    (hresult : result ∈ support 𝒟[computation]) : result ∈ support computation :=
+  (mem_support_iff_of_evalDist_eq (mx := computation) (mx' := 𝒟[computation]) rfl result).mpr hresult
+
+private theorem pmf_mem_of_evalDist {Result : Type} (law : PMF Result) (result : Result)
+    (hresult : result ∈ support 𝒟[law]) : result ∈ law.support := by
+  change result ∈ (𝒟[law]).support at hresult
+  simpa only [PMF.evalDist_eq, SPMF.support_liftM] using hresult
+
+theorem referenceCheckpointGame_newContact_le_mark (stop : FrontierStop)
+    [∀ parameter words frontier, DecidablePred (stop parameter words frontier)]
+    (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords) (adversary : Adversary) (budget : Nat)
+    (hbound : HasHashQueryBound scheme adversary budget) (hsmall : budget < Fintype.card Digest) :
+    let law := referenceInstrumentedGame (checkpointObserver stop) (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary
+    ((1 - (budget : ENNReal) / Fintype.card Digest) * (Fintype.card Digest : ENNReal)) *
+      Pr[fun result => result.2.2.ContactAfterStop stop result.1 (referenceFamilyWords result.2.1 dummy) address | law] ≤
+      (2 * budget : Nat) * Pr[fun result => stop result.1 (referenceFamilyWords result.2.1 dummy) result.2.2.frontier result.2.2.before | law] := by
+  dsimp only
+  rw [← prefixInstrumentedObservedGame_original (checkpointObserver stop) _ _ (canonicalGraphInputs_subset_gameInputs adversary) address]
+  unfold prefixInstrumentedObservedGame
+  apply scaled_probability_bind_le
+  intro parameter hparameter
+  apply scaled_probability_bind_le
+  intro ftsSecret _
+  apply scaled_probability_bind_le
+  intro selections hselections
+  apply scaled_probability_bind_le
+  intro other _
+  apply scaled_probability_bind_le
+  intro auxiliary hauxiliary
+  let words := referenceFamilyWords selections dummy
+  let segment := OtsPrefix.atAddress parameter words address
+  let inputs := canonicalGraphGameInputs adversary
+  let hencoding := canonicalEncodingInputs_subset_gameInputs adversary parameter
+  let hgraph := canonicalGraphInputs_subset_gameInputs adversary parameter
+  have hreal : ∀ result ∈ (PartialChainEndpoint.realRun (fun _ => OtsPrefix.uniformImpl)
+      (fun endpoint => segment.seedGame inputs hencoding hgraph auxiliary other.val ftsSecret words endpoint adversary) (fun _ _ => none)).support,
+      result.2.1.2.hashCalls ≤ budget :=
+    prefixObservedRun_hashCalls_le parameter (probComp_mem_of_evalDist _ parameter hparameter) ftsSecret
+      address.1 address.2.1 address.2.2.1 address.2.2.2 dummy adversary selections (pmf_mem_of_evalDist _ selections hselections)
+      budget hbound other auxiliary (pmf_mem_of_evalDist _ auxiliary hauxiliary)
+  have hseed := checkpointSeed_newContact_le_mark stop parameter words address inputs hencoding hgraph auxiliary other.val ftsSecret adversary budget hreal hsmall
+  simpa only [bind_pure_comp, ← PMF.monad_map_eq_map, evalDist_map, probEvent_map, Function.comp_def,
+    PMF.evalDist_eq, SPMF.probEvent_liftM, mul_assoc] using hseed
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTraceRestart.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTraceRestart.lean
new file mode 100644
index 000000000..f5660c490
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTraceRestart.lean
@@ -0,0 +1,138 @@
+import SphincsSecurity.Proof.Ots.OtsTraceCheckpointBudget
+import SphincsSecurity.Proof.Chains.AdaptiveChainCheckpointContact
+import SphincsSecurity.Proof.Ots.OtsTraceCheckpointObservation
+namespace SphincsSecurity.Concrete.OtsPrefix
+
+open _root_.OracleComp OracleSpec PartialChainEndpoint
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+variable (segment : OtsPrefix) (stop : FrontierStop)
+  [∀ parameter words frontier, DecidablePred (stop parameter words frontier)] (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs) (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+  (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph) (secrets : OtsFrontierValues)
+  (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (adversary : Adversary)
+
+theorem traceCheckpointRun_newContact_probability :
+    Pr[fun result => (stop segment.parameter words result.2.1.frontier result.2.1.before ∧
+        ¬OtsContactTrace.Seen segment result.1 result.2.1.before) ∧
+      OtsContactTrace.Seen segment result.1 (result.2.1.before * result.2.1.after) |
+      realRun (fun _ => uniformImpl)
+        (fun endpoint => segment.instrumentedSeedGame (checkpointObserver stop) inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+        (fun _ _ => none)] =
+      Pr[fun result => (stop segment.parameter words
+          (segment.seedFrontier inputs hencoding hgraph auxiliary secrets words result.1) result.2.1.1.1.1 ∧
+          ¬Contact result.2.1.2 result.1) ∧ Contact result.2.2.2 result.1 |
+        segment.traceCheckpointRun stop inputs hencoding hgraph auxiliary secrets ftsSecret words adversary] := by
+  rw [← segment.traceCheckpointRun_project stop inputs hencoding hgraph auxiliary secrets ftsSecret words adversary,
+    ← PMF.monad_map_eq_map, probEvent_map]
+  simp only [Function.comp_def, probEvent_eq_tsum_ite, PMF.probOutput_eq_apply]
+  apply tsum_congr
+  intro result
+  by_cases hr : result ∈ (segment.traceCheckpointRun stop inputs hencoding hgraph auxiliary secrets ftsSecret words adversary).support
+  · have hs := segment.traceCheckpointRun_observation stop inputs hencoding hgraph auxiliary secrets ftsSecret words adversary result hr
+    simp only [hs.1, hs.2.1]
+  · have hz : segment.traceCheckpointRun stop inputs hencoding hgraph auxiliary secrets ftsSecret words adversary result = 0 := not_not.mp hr
+    simp only [hz, ite_self]
+
+theorem instrumentedCheckpoint_newContact_le (budget : Nat)
+    (hreal : ∀ result ∈ (realRun (fun _ => uniformImpl)
+      (fun endpoint => segment.seedGame inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary) (fun _ _ => none)).support,
+      result.2.1.2.hashCalls ≤ budget)
+    (hsmall : budget < Fintype.card Digest) :
+    let law := realRun (fun _ => uniformImpl)
+      (fun endpoint => segment.instrumentedSeedGame (checkpointObserver stop) inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+      (fun _ _ => none)
+    (1 - (budget : ENNReal) / Fintype.card Digest) * ((Fintype.card Digest : ENNReal) *
+      Pr[fun result => (stop segment.parameter words result.2.1.frontier result.2.1.before ∧ ¬OtsContactTrace.Seen segment result.1 result.2.1.before) ∧
+        OtsContactTrace.Seen segment result.1 (result.2.1.before * result.2.1.after) | law]) ≤
+    ∑' result, law result *
+      (((OtsContactTrace.prefixCalls segment result.2.1.before + 2 * OtsContactTrace.prefixCalls segment result.2.1.after : Nat) : ENNReal) *
+        if stop segment.parameter words result.2.1.frontier result.2.1.before ∧ ¬OtsContactTrace.Seen segment result.1 result.2.1.before then 1 else 0) := by
+  dsimp only
+  let checkpoint := segment.traceCheckpointRun stop inputs hencoding hgraph auxiliary secrets ftsSecret words adversary
+  let marked := fun endpoint (middle : ((OtsContactTrace.Trace × OracleComp segment.VisibleWorld (Bool × SigningBoundaryTrace)) × Nat) ×
+      (Fin segment.digit.val → Digest → Option Digest)) =>
+    stop segment.parameter words (segment.seedFrontier inputs hencoding hgraph auxiliary secrets words endpoint) middle.1.1.1 ∧
+      ¬Contact middle.2 endpoint
+  have hkernel := realCheckpointRun_contact_charge
+    (fun endpoint => extendAux uniformImpl (segment.seedOracle inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint))
+    (segment.traceCheckpointBefore stop inputs hencoding hgraph auxiliary secrets ftsSecret words adversary)
+    (fun _ middle => QueryPause.traced (segment.visibleObservationTrace auxiliary.high) middle.1.1.2) (fun _ _ => none)
+    marked budget (fun _ _ h => h.2)
+    (fun endpoint middle hmiddle _ result hresult =>
+      (segment.traceCheckpoint_budget stop inputs hencoding hgraph auxiliary secrets ftsSecret words adversary budget hreal hsmall
+        endpoint middle hmiddle result hresult).2)
+  rw [segment.traceCheckpointRun_newContact_probability stop inputs hencoding hgraph auxiliary secrets ftsSecret words adversary]
+  apply hkernel.trans
+  rw [← segment.traceCheckpointRun_project stop inputs hencoding hgraph auxiliary secrets ftsSecret words adversary, expectation_map]
+  apply ENNReal.tsum_le_tsum
+  intro result
+  by_cases hr : result ∈ checkpoint.support
+  · have hs := segment.traceCheckpointRun_observation stop inputs hencoding hgraph auxiliary secrets ftsSecret words adversary result hr
+    apply mul_le_mul' le_rfl
+    by_cases hm : marked result.1 result.2.1
+    · have hm' : stop segment.parameter words
+          (segment.seedFrontier inputs hencoding hgraph auxiliary secrets words result.1) result.2.1.1.1.1 ∧
+          ¬OtsContactTrace.Seen segment result.1 result.2.1.1.1.1 := ⟨hm.1, fun hc => hm.2 (hs.1.mp hc)⟩
+      simp only [if_pos hm, if_pos hm', mul_one]
+      exact_mod_cast (Nat.add_le_add hs.2.2.1 (Nat.mul_le_mul_left 2 hs.2.2.2))
+    · have hm' : ¬(stop segment.parameter words
+          (segment.seedFrontier inputs hencoding hgraph auxiliary secrets words result.1) result.2.1.1.1.1 ∧
+          ¬OtsContactTrace.Seen segment result.1 result.2.1.1.1.1) := by
+        intro h
+        exact hm ⟨h.1, fun hc => h.2 (hs.1.mpr hc)⟩
+      simp only [if_neg hm, if_neg hm', mul_zero, le_refl]
+  · have hz : checkpoint result = 0 := not_not.mp hr
+    simp only [checkpoint, traceCheckpointRun] at hz
+    simp only [hz, zero_mul, zero_le]
+
+theorem instrumentedCheckpoint_newContact_le_mark (budget : Nat)
+    (hreal : ∀ result ∈ (realRun (fun _ => uniformImpl)
+      (fun endpoint => segment.seedGame inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary) (fun _ _ => none)).support,
+      result.2.1.2.hashCalls ≤ budget)
+    (hsmall : budget < Fintype.card Digest) :
+    let law := realRun (fun _ => uniformImpl)
+      (fun endpoint => segment.instrumentedSeedGame (checkpointObserver stop) inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+      (fun _ _ => none)
+    (1 - (budget : ENNReal) / Fintype.card Digest) * ((Fintype.card Digest : ENNReal) *
+      Pr[fun result => (stop segment.parameter words result.2.1.frontier result.2.1.before ∧ ¬OtsContactTrace.Seen segment result.1 result.2.1.before) ∧
+        OtsContactTrace.Seen segment result.1 (result.2.1.before * result.2.1.after) | law]) ≤
+      (2 * budget : Nat) * Pr[fun result => stop segment.parameter words result.2.1.frontier result.2.1.before | law] := by
+  dsimp only
+  let aux := fun endpoint => extendAux uniformImpl (segment.seedOracle inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint)
+  let before := segment.traceCheckpointBefore stop inputs hencoding hgraph auxiliary secrets ftsSecret words adversary
+  let after := fun (_ : Digest) (middle : ((OtsContactTrace.Trace × OracleComp segment.VisibleWorld (Bool × SigningBoundaryTrace)) × Nat) ×
+      (Fin segment.digit.val → Digest → Option Digest)) =>
+    QueryPause.traced (segment.visibleObservationTrace auxiliary.high) middle.1.1.2
+  let marked := fun endpoint (middle : ((OtsContactTrace.Trace × OracleComp segment.VisibleWorld (Bool × SigningBoundaryTrace)) × Nat) ×
+      (Fin segment.digit.val → Digest → Option Digest)) =>
+    stop segment.parameter words (segment.seedFrontier inputs hencoding hgraph auxiliary secrets words endpoint) middle.1.1.1 ∧
+      ¬Contact middle.2 endpoint
+  have hkernel := realCheckpointRun_contact_le_mark aux before after (fun _ _ => none) marked budget (fun _ _ h => h.2)
+    (fun endpoint middle hmiddle _ result hresult =>
+      (segment.traceCheckpoint_budget stop inputs hencoding hgraph auxiliary secrets ftsSecret words adversary budget hreal hsmall
+        endpoint middle hmiddle result hresult).2)
+    (fun result hresult _ => by
+      have hs := realCheckpointRun_support aux before after (fun _ _ => none) result hresult
+      exact (segment.traceCheckpoint_budget stop inputs hencoding hgraph auxiliary secrets ftsSecret words adversary budget hreal hsmall
+        result.1 result.2.1 hs.1 result.2.2 hs.2).1)
+  rw [segment.traceCheckpointRun_newContact_probability stop inputs hencoding hgraph auxiliary secrets ftsSecret words adversary]
+  rw [← realCheckpointRun_mark_probability aux before after (fun _ _ => none) marked] at hkernel
+  apply hkernel.trans
+  apply mul_le_mul' le_rfl
+  rw [← segment.traceCheckpointRun_project stop inputs hencoding hgraph auxiliary secrets ftsSecret words adversary,
+    ← PMF.monad_map_eq_map, probEvent_map]
+  simp only [Function.comp_def, probEvent_eq_tsum_ite, marked]
+  apply ENNReal.tsum_le_tsum
+  intro result
+  by_cases hm : stop segment.parameter words
+      (segment.seedFrontier inputs hencoding hgraph auxiliary secrets words result.1) result.2.1.1.1.1
+  · simp only [hm, true_and, if_true]
+    split
+    · exact le_rfl
+    · exact bot_le
+  · simp only [hm, false_and, if_false, le_refl]
+
+end SphincsSecurity.Concrete.OtsPrefix
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTraceRowSource.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTraceRowSource.lean
new file mode 100644
index 000000000..02b52401d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTraceRowSource.lean
@@ -0,0 +1,45 @@
+import SphincsSecurity.Proof.Ots.OtsTraceRows
+import SphincsSecurity.Proof.Ots.OtsContactFirstLaw
+import SphincsSecurity.Proof.Ots.EncodingMarkerBound
+namespace SphincsSecurity.Concrete.OtsPrefix
+
+open _root_.OracleComp OracleSpec PartialChainEndpoint OtsContactTrace
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+variable (segment : OtsPrefix) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs) (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+  (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph) (secrets : OtsFrontierValues)
+  (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (adversary : Adversary)
+
+theorem visibleInstrumentedContact_trace (endpoint : Digest) :
+    (fun result : ContactResult => (result.output, result.before * result.after)) <$>
+      segment.visibleInstrumentedSeedGame contactObserver inputs hencoding hgraph auxiliary secrets ftsSecret words adversary endpoint =
+      QueryPause.traced (segment.visibleObservationTrace auxiliary.high)
+        (segment.visibleSeedGame inputs hencoding hgraph auxiliary secrets ftsSecret words adversary endpoint) := by
+  rw [visibleInstrumentedSeedGame, ← simulateQ_map, contactObserver_trace]
+  exact (segment.visible_observation_program auxiliary.high _).symm
+
+theorem instrumentedContact_rows (result : Digest × ContactResult × (Fin segment.digit.val → Digest → Option Digest))
+    (hr : result ∈ (realRun (fun _ => uniformImpl)
+      (fun endpoint => segment.instrumentedSeedGame contactObserver inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+      (fun _ _ => none)).support) :
+    RowsObserved segment (result.2.1.before * result.2.1.after) result.2.2 := by
+  rw [← segment.visibleInstrumentedSeedGame_real contactObserver inputs hencoding hgraph auxiliary secrets ftsSecret words adversary] at hr
+  have hlazy := realRun_support_lazy _ _ _ result hr
+  have htrace : ((result.2.1.output, result.2.1.before * result.2.1.after), result.2.2) ∈
+      (lazyRun (extendAux uniformImpl (segment.seedOracle inputs hencoding hgraph auxiliary secrets ftsSecret words result.1))
+        (QueryPause.traced (segment.visibleObservationTrace auxiliary.high)
+          (segment.visibleSeedGame inputs hencoding hgraph auxiliary secrets ftsSecret words adversary result.1)) (fun _ _ => none)).support := by
+    rw [← segment.visibleInstrumentedContact_trace inputs hencoding hgraph auxiliary secrets ftsSecret words adversary, lazyRun_map,
+      PMF.mem_support_map_iff]
+    exact ⟨result.2, hlazy, rfl⟩
+  have h := segment.visible_traced_rows auxiliary.high
+    (extendAux uniformImpl (segment.seedOracle inputs hencoding hgraph auxiliary secrets ftsSecret words result.1))
+    (CausalFrontierProgram.game segment.parameter (segment.seedOracle inputs hencoding hgraph auxiliary secrets ftsSecret words result.1)
+      ftsSecret words (segment.seedFrontier inputs hencoding hgraph auxiliary secrets words result.1) adversary)
+    1 (fun _ _ => none) (rowsObserved_empty segment) _ htrace
+  simpa only [one_mul] using h
+
+end SphincsSecurity.Concrete.OtsPrefix
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTraceRows.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTraceRows.lean
new file mode 100644
index 000000000..700880542
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTraceRows.lean
@@ -0,0 +1,111 @@
+import SphincsSecurity.Proof.Ots.OtsPrefixVisibleContact
+import SphincsSecurity.Proof.Base.QueryTraceInvariant
+namespace SphincsSecurity.Concrete.OtsContactTrace
+
+open _root_.OracleComp OracleSpec PartialChainEndpoint
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+
+def SeenRow (segment : OtsPrefix) (query : segment.Query) (answer : Digest) (trace : Trace) : Prop :=
+  ∃ entry ∈ trace.toList, segment.parse entry.1 = some query ∧ truncateHash entry.2 = answer
+
+theorem seenRow_one (segment : OtsPrefix) (query : segment.Query) (answer : Digest) : ¬SeenRow segment query answer 1 := by
+  simp [SeenRow]
+
+theorem seenRow_of (segment : OtsPrefix) (query : segment.Query) (answer : Digest) (entry : HashInput × HashOutput) :
+    SeenRow segment query answer (FreeMonoid.of entry) ↔ segment.parse entry.1 = some query ∧ truncateHash entry.2 = answer := by
+  simp [SeenRow]
+
+theorem seenRow_mul (segment : OtsPrefix) (query : segment.Query) (answer : Digest) (before after : Trace) :
+    SeenRow segment query answer (before * after) ↔ SeenRow segment query answer before ∨ SeenRow segment query answer after := by
+  simp only [SeenRow, FreeMonoid.toList_mul, List.mem_append, or_and_right, exists_or]
+
+def RowsObserved (segment : OtsPrefix) (trace : Trace) (observed : Fin segment.digit.val → Digest → Option Digest) : Prop :=
+  ∀ query : segment.Query, ∀ answer, SeenRow segment query answer trace ↔ observed query.1 query.2 = some answer
+
+theorem rowsObserved_empty (segment : OtsPrefix) : RowsObserved segment 1 (fun _ _ => none) := by
+  intro query answer
+  simp only [seenRow_one, reduceCtorEq]
+
+end SphincsSecurity.Concrete.OtsContactTrace
+
+namespace SphincsSecurity.Concrete.OtsPrefix
+
+open _root_.OracleComp OracleSpec PartialChainEndpoint OtsContactTrace
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+
+private theorem record_some_iff {State : Type} [DecidableEq State] {n : Nat}
+    (observed : Fin n → State → Option State) (query target : Fin n × State) (answer value : State)
+    (hc : observed query.1 query.2 = none ∨ observed query.1 query.2 = some answer) :
+    record observed query answer target.1 target.2 = some value ↔
+      observed target.1 target.2 = some value ∨ query = target ∧ answer = value := by
+  by_cases he : target = query
+  · subst target
+    simp only [record, Function.update_self, Option.some.injEq, true_and]
+    constructor
+    · exact Or.inr
+    · rintro (h | h)
+      · rcases hc with hc | hc
+        · simp only [hc, reduceCtorEq] at h
+        · exact Option.some.inj (hc.symm.trans h)
+      · exact h
+  · have hrow : record observed query answer target.1 target.2 = observed target.1 target.2 := by
+      by_cases hl : target.1 = query.1
+      · have hi : target.2 ≠ query.2 := fun hi => he (Prod.ext hl hi)
+        simp only [record, hl, Function.update_self, Function.update_of_ne hi]
+      · simp only [record, Function.update_of_ne hl]
+    simp only [hrow, Ne.symm he, false_and, or_false]
+
+theorem visible_step_rows (segment : OtsPrefix) (high : segment.Query → High) (auxiliary : QueryImpl OracleWorld PMF)
+    (trace : Trace) (observed : Fin segment.digit.val → Digest → Option Digest) (hrows : RowsObserved segment trace observed)
+    (input : OracleWorld.Domain) (result : OracleWorld.Range input × (Fin segment.digit.val → Digest → Option Digest))
+    (hr : result ∈ ((segment.visibleLazyImpl high auxiliary input).run observed).support) :
+    RowsObserved segment (trace * hashObservationTrace input result.1) result.2 := by
+  cases input with
+  | inl input =>
+      simp only [visibleLazyImpl, QueryImpl.apply_compose, visibleWorldImpl, simulateQ_spec_query,
+        lazyImpl, StateT.run_mk, PMF.mem_support_map_iff] at hr
+      obtain ⟨answer, _, rfl⟩ := hr
+      simpa only [hashObservationTrace, mul_one] using hrows
+  | inr bytes =>
+      cases hp : segment.parse bytes with
+      | none =>
+          simp only [visibleLazyImpl, QueryImpl.apply_compose, visibleWorldImpl, visibleHashImpl, hp,
+            simulateQ_spec_query, lazyImpl, StateT.run_mk, PMF.mem_support_map_iff] at hr
+          obtain ⟨answer, _, rfl⟩ := hr
+          intro query value
+          simpa only [hashObservationTrace, seenRow_mul, seenRow_of, hp, reduceCtorEq, false_and, or_false] using hrows query value
+      | some query =>
+          have hb := (segment.parse_some_iff bytes query).mp hp
+          subst bytes
+          simp only [visibleLazyImpl, QueryImpl.apply_compose, visibleWorldImpl, visibleHashImpl, parse_input,
+            simulateQ_map, simulateQ_spec_query, lazyImpl, StateT.run_map, StateT.run_mk,
+            PMF.monad_map_eq_map, PMF.map_comp, Function.comp_def, PMF.mem_support_map_iff] at hr
+          obtain ⟨answer, ha, rfl⟩ := hr
+          have hc : observed query.1 query.2 = none ∨ observed query.1 query.2 = some answer := by
+            cases hrow : observed query.1 query.2 with
+            | none => exact Or.inl rfl
+            | some old =>
+                rw [hrow, rowLaw, PMF.mem_support_pure_iff] at ha
+                exact Or.inr (congrArg some ha.symm)
+          intro target value
+          rw [hashObservationTrace, seenRow_mul, seenRow_of, hrows target value, record_some_iff observed query target answer value hc]
+          simp only [parse_input, Option.some.injEq, truncate_combine]
+
+theorem visible_traced_rows (segment : OtsPrefix) (high : segment.Query → High) (auxiliary : QueryImpl OracleWorld PMF)
+    {Result : Type} (computation : OracleComp OracleWorld Result) (history : Trace)
+    (observed : Fin segment.digit.val → Digest → Option Digest) (hrows : RowsObserved segment history observed)
+    (result : (Result × Trace) × (Fin segment.digit.val → Digest → Option Digest))
+    (hr : result ∈ (lazyRun auxiliary (QueryPause.traced (segment.visibleObservationTrace high)
+      (simulateQ (segment.visibleWorldImpl high) computation)) observed).support) :
+    RowsObserved segment (history * result.1.2) result.2 := by
+  have ht : QueryPause.traced (segment.visibleObservationTrace high) (simulateQ (segment.visibleWorldImpl high) computation) =
+      simulateQ (segment.visibleWorldImpl high) (QueryPause.traced hashObservationTrace computation) :=
+    segment.visible_observation_program high computation
+  rw [ht, lazyRun, ← QueryImpl.simulateQ_compose] at hr
+  exact QueryPause.traced_simulation_invariant hashObservationTrace (segment.visibleLazyImpl high auxiliary)
+    (RowsObserved segment) (fun trace rows h input answer ha => segment.visible_step_rows high auxiliary trace rows h input answer ha)
+    computation history observed hrows result hr
+
+end SphincsSecurity.Concrete.OtsPrefix
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTwoEdgeProbability.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTwoEdgeProbability.lean
new file mode 100644
index 000000000..4156e49e0
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTwoEdgeProbability.lean
@@ -0,0 +1,107 @@
+import SphincsSecurity.Proof.Ots.OtsTwoEdgeSource
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition Finset.univ
+
+theorem referenceContactGame_twoEdge_law (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (fun result => decide (result.2.2.TwoEdgeAt result.1 (referenceFamilyWords result.2.1 dummy) address)) <$>
+      referenceContactGame inputs hencoding dummy adversary = prefixTwoEdgeGame inputs hencoding hgraph address dummy adversary := by
+  rw [← prefixContactObservedGame_original inputs hencoding hgraph address dummy adversary]
+  unfold prefixContactObservedGame prefixInstrumentedObservedGame prefixTwoEdgeGame
+  simp only [map_bind, map_pure]
+  apply congrArg (𝒟[sampleParameter] >>= ·)
+  funext parameter
+  apply congrArg (𝒟[sampleFtsSecrets] >>= ·)
+  funext ftsSecret
+  apply congrArg (𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit] >>= ·)
+  funext selections
+  let words := referenceFamilyWords selections dummy
+  let segment := OtsPrefix.atAddress parameter words address
+  apply congrArg (𝒟[PMF.uniformOfFintype segment.ErasedSecrets] >>= ·)
+  funext other
+  apply congrArg (𝒟[segment.referenceAuxSeedLaw inputs (hencoding parameter) (hgraph parameter) selections] >>= ·)
+  funext auxiliary
+  have h := congrArg (fun law : PMF Bool => 𝒟[law])
+    (contactSeed_twoEdge_eq parameter words address inputs (hencoding parameter) (hgraph parameter) auxiliary other.val ftsSecret adversary)
+  simpa only [← PMF.monad_map_eq_map, evalDist_map, bind_map_left, bind_pure_comp, Functor.map_map, Function.comp_def] using h
+
+theorem referenceContactGame_twoEdge_eq (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (address : OtsPrefix.ChainAddress) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    Pr[fun result => result.2.2.TwoEdgeAt result.1 (referenceFamilyWords result.2.1 dummy) address |
+      referenceContactGame inputs hencoding dummy adversary] =
+    Pr[= true | prefixTwoEdgeGame inputs hencoding hgraph address dummy adversary] := by
+  rw [← referenceContactGame_twoEdge_law inputs hencoding hgraph address dummy adversary, ← probEvent_eq_eq_probOutput, probEvent_map]
+  simp only [Function.comp_def, decide_eq_true_eq]
+
+def ContactResult.TwoEdge (parameter : PublicParameter) (words : OtsReferenceWords) (result : ContactResult) : Prop :=
+  ∃ address, result.TwoEdgeAt parameter words address
+
+theorem referenceContactGame_twoEdge_le_sum (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    Pr[fun result => result.2.2.TwoEdge result.1 (referenceFamilyWords result.2.1 dummy) |
+      referenceContactGame inputs hencoding dummy adversary] ≤
+      ∑ address : OtsPrefix.ChainAddress, Pr[fun result => result.2.2.TwoEdgeAt result.1 (referenceFamilyWords result.2.1 dummy) address |
+        referenceContactGame inputs hencoding dummy adversary] := by
+  let law := referenceContactGame inputs hencoding dummy adversary
+  let event := fun address : OtsPrefix.ChainAddress => fun result : InstrumentedResult ContactResult =>
+    result.2.2.TwoEdgeAt result.1 (referenceFamilyWords result.2.1 dummy) address
+  refine (_root_.probEvent_mono (mx := law) (q := fun result => ∃ address ∈ (Finset.univ : Finset OtsPrefix.ChainAddress), event address result) ?_).trans
+    (probEvent_exists_finset_le_sum Finset.univ law event)
+  rintro result _ ⟨address, ha⟩
+  exact ⟨address, Finset.mem_univ address, ha⟩
+
+theorem referenceContactGame_twoEdge_sum_cost_le (dummy : OtsReferenceWords) (adversary : Adversary) (q : Nat)
+    (hbound : HasHashQueryBound scheme adversary q) (hsmall : q < Fintype.card Digest) :
+    (1 - (q : ENNReal) / Fintype.card Digest) *
+      (∑ address : OtsPrefix.ChainAddress, Pr[fun result => result.2.2.TwoEdgeAt result.1 (referenceFamilyWords result.2.1 dummy) address |
+        referenceContactGame (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary]) ≤
+      prefixTwoEdgeRate q * (∑' result : ReferenceRecordedResult, Pr[= result | referenceRecordedGame (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] * (result.prefixCalls dummy : ENNReal)) := by
+  simp only [referenceContactGame_twoEdge_eq _ _ (canonicalGraphInputs_subset_gameInputs adversary)]
+  have hsum := Finset.sum_le_sum (s := (Finset.univ : Finset OtsPrefix.ChainAddress))
+    fun address _ => prefixTwoEdgeGame_le address dummy adversary q hbound hsmall
+  rw [← Finset.mul_sum] at hsum
+  have hlower := Finset.sum_le_sum (s := (Finset.univ : Finset OtsPrefix.ChainAddress))
+    fun address _ => prefixIdealCostGame_lower address dummy adversary q hbound
+  rw [← Finset.mul_sum] at hlower
+  simp only [prefixCountedObservedGame_original, tsum_probOutput_map_mul, ReferenceRecordedResult.prefixCounted] at hlower
+  conv at hlower =>
+    rhs
+    rw [← tsum_fintype (L := SummationFilter.unconditional OtsPrefix.ChainAddress), ENNReal.tsum_comm]
+    simp only [tsum_fintype, ← Finset.mul_sum, ← Nat.cast_sum]
+  have hscaled := mul_le_mul' (le_refl (1 - (q : ENNReal) / Fintype.card Digest)) hsum
+  rw [mul_left_comm] at hscaled
+  exact hscaled.trans (mul_le_mul' le_rfl hlower)
+
+theorem referenceContactGame_twoEdge_cost_le (dummy : OtsReferenceWords) (adversary : Adversary) (q : Nat)
+    (hbound : HasHashQueryBound scheme adversary q) (hsmall : q < Fintype.card Digest) :
+    (1 - (q : ENNReal) / Fintype.card Digest) *
+      Pr[fun result => result.2.2.TwoEdge result.1 (referenceFamilyWords result.2.1 dummy) |
+        referenceContactGame (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] ≤
+      prefixTwoEdgeRate q * (∑' result : ReferenceRecordedResult, Pr[= result | referenceRecordedGame (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] * (result.prefixCalls dummy : ENNReal)) :=
+  (mul_le_mul' le_rfl (referenceContactGame_twoEdge_le_sum _ _ dummy adversary)).trans
+    (referenceContactGame_twoEdge_sum_cost_le dummy adversary q hbound hsmall)
+
+theorem referenceContactGame_twoEdge_le (dummy : OtsReferenceWords) (adversary : Adversary) (q : Nat)
+    (hbound : HasHashQueryBound scheme adversary q) (hsmall : q < Fintype.card Digest) :
+    Pr[fun result => result.2.2.TwoEdge result.1 (referenceFamilyWords result.2.1 dummy) |
+      referenceContactGame (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] ≤
+      (prefixTwoEdgeRate q * (∑' result : ReferenceRecordedResult, Pr[= result | referenceRecordedGame (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] * (result.prefixCalls dummy : ENNReal))) /
+        (1 - (q : ENNReal) / Fintype.card Digest) := by
+  have hcard : (Fintype.card Digest : ENNReal) ≠ 0 := by exact_mod_cast Fintype.card_ne_zero
+  have hpositive : 0 < 1 - (q : ENNReal) / Fintype.card Digest := by
+    apply tsub_pos_iff_lt.mpr
+    rw [ENNReal.div_lt_iff (Or.inl hcard) (Or.inl (by finiteness)), one_mul]
+    exact_mod_cast hsmall
+  apply (ENNReal.le_div_iff_mul_le (Or.inl (ne_of_gt hpositive)) (Or.inl (by finiteness))).mpr
+  simpa only [mul_comm] using referenceContactGame_twoEdge_cost_le dummy adversary q hbound hsmall
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTwoEdgeSource.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTwoEdgeSource.lean
new file mode 100644
index 000000000..fd8a6073c
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTwoEdgeSource.lean
@@ -0,0 +1,63 @@
+import SphincsSecurity.Proof.Ots.OtsTraceRowSource
+import SphincsSecurity.Proof.Ots.OtsTwoEdgeTrace
+import SphincsSecurity.Proof.Ots.OtsPrefixTwoEdgeProbability
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec PartialChainEndpoint
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphLabels canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+def ContactResult.TwoEdgeAt (parameter : PublicParameter) (words : OtsReferenceWords)
+    (address : OtsPrefix.ChainAddress) (result : ContactResult) : Prop :=
+  OtsContactTrace.SeenTwoEdge (OtsPrefix.atAddress parameter words address)
+    (result.frontier address.1 address.2.1 address.2.2.1 address.2.2.2) (result.before * result.after)
+
+theorem OtsPrefix.instrumentedContact_twoEdge (segment : OtsPrefix) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs segment.parameter ⊆ inputs) (hgraph : canonicalGraphInputs segment.parameter ⊆ inputs)
+    (auxiliary : segment.ReferenceAuxSeed inputs hencoding hgraph) (secrets : OtsFrontierValues)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (adversary : Adversary)
+    (result : Digest × ContactResult × (Fin segment.digit.val → Digest → Option Digest))
+    (hr : result ∈ (realRun (fun _ => uniformImpl)
+      (fun endpoint => segment.instrumentedSeedGame contactObserver inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+      (fun _ _ => none)).support) :
+    OtsContactTrace.SeenTwoEdge segment result.1 (result.2.1.before * result.2.1.after) ↔ TwoEdgeEvent result.2.2 result.1 :=
+  (segment.instrumentedContact_rows inputs hencoding hgraph auxiliary secrets ftsSecret words adversary result hr).twoEdge_iff result.1
+
+theorem contactSeed_twoEdge_eq (parameter : PublicParameter) (words : OtsReferenceWords) (address : OtsPrefix.ChainAddress)
+    (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (hgraph : canonicalGraphInputs parameter ⊆ inputs)
+    (auxiliary : (OtsPrefix.atAddress parameter words address).ReferenceAuxSeed inputs hencoding hgraph) (secrets : OtsFrontierValues)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (adversary : Adversary) :
+    let segment := OtsPrefix.atAddress parameter words address
+    (realRun (fun _ => OtsPrefix.uniformImpl)
+      (fun endpoint => segment.instrumentedSeedGame contactObserver inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+      (fun _ _ => none)).map (fun result => decide (result.2.1.TwoEdgeAt parameter words address)) =
+    (realRun (fun _ => OtsPrefix.uniformImpl)
+      (fun endpoint => segment.seedGame inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+      (fun _ _ => none)).map (fun result => decide (TwoEdgeEvent result.2.2 result.1)) := by
+  dsimp only
+  let segment := OtsPrefix.atAddress parameter words address
+  rw [← segment.instrumentedContact_real_forget inputs hencoding hgraph auxiliary secrets ftsSecret words adversary,
+    PMF.map_comp]
+  apply PMF.ext
+  intro value
+  simp only [PMF.map_apply]
+  apply tsum_congr
+  intro result
+  by_cases hr : result ∈ (realRun (fun _ => OtsPrefix.uniformImpl)
+      (fun endpoint => segment.instrumentedSeedGame contactObserver inputs hencoding hgraph auxiliary secrets ftsSecret words endpoint adversary)
+      (fun _ _ => none)).support
+  swap
+  · have hz := not_not.mp hr
+    simp only [segment] at hz ⊢
+    simp only [hz, ite_self]
+  have he := segment.instrumentedContact_endpoint inputs hencoding hgraph auxiliary secrets ftsSecret words adversary result hr
+  have hc := segment.instrumentedContact_twoEdge inputs hencoding hgraph auxiliary secrets ftsSecret words adversary result hr
+  change result.2.1.frontier address.1 address.2.1 address.2.2.1 address.2.2.2 = result.1 at he
+  simp only [ContactResult.TwoEdgeAt, he, Function.comp_def]
+  rw [hc]
+  by_cases hv : value = decide (TwoEdgeEvent result.2.2 result.1)
+  · simp only [if_pos hv, segment]
+  · simp only [if_neg hv]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTwoEdgeTrace.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTwoEdgeTrace.lean
new file mode 100644
index 000000000..ef12fa886
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsTwoEdgeTrace.lean
@@ -0,0 +1,54 @@
+import SphincsSecurity.Proof.Ots.OtsTraceRows
+import SphincsSecurity.Proof.Chains.AdaptiveChainCapTwoEdge
+namespace SphincsSecurity.Concrete.PartialChainEndpoint
+
+set_option backward.isDefEq.respectTransparency false
+
+theorem twoEdgeEvent_iff_rows {State : Type} {depth : Nat} (observed : Fin depth → State → Option State) (endpoint : State) :
+    TwoEdgeEvent observed endpoint ↔ ∃ first last : Fin depth × State,
+      first.1.val + 2 = depth ∧ last.1.val + 1 = depth ∧
+        observed first.1 first.2 = some last.2 ∧ observed last.1 last.2 = some endpoint := by
+  cases depth with
+  | zero => simp only [TwoEdgeEvent, Prod.exists, Fin.exists_fin_zero]
+  | succ depth =>
+      cases depth with
+      | zero =>
+          constructor
+          · exact False.elim
+          · rintro ⟨first, _, hf, _⟩
+            omega
+      | succ depth =>
+          constructor
+          · rintro ⟨start, middle, hf, hl⟩
+            exact ⟨⟨(Fin.last depth).castSucc, start⟩, ⟨Fin.last (depth + 1), middle⟩, rfl, rfl, hf, hl⟩
+          · rintro ⟨⟨first, start⟩, ⟨last, middle⟩, hf, hl, hfirst, hlast⟩
+            change first.val + 2 = depth + 2 at hf
+            change last.val + 1 = depth + 2 at hl
+            have hfi : first = (Fin.last depth).castSucc := by
+              apply Fin.ext
+              simp only [Fin.val_castSucc, Fin.val_last]
+              omega
+            have hla : last = Fin.last (depth + 1) := by
+              apply Fin.ext
+              simp only [Fin.val_last]
+              omega
+            subst first last
+            exact ⟨start, middle, hfirst, hlast⟩
+
+end SphincsSecurity.Concrete.PartialChainEndpoint
+
+namespace SphincsSecurity.Concrete.OtsContactTrace
+
+set_option backward.isDefEq.respectTransparency false
+
+def SeenTwoEdge (segment : OtsPrefix) (endpoint : Digest) (trace : Trace) : Prop :=
+  ∃ first last : segment.Query, first.1.val + 2 = segment.digit.val ∧ last.1.val + 1 = segment.digit.val ∧
+    SeenRow segment first last.2 trace ∧ SeenRow segment last endpoint trace
+
+theorem RowsObserved.twoEdge_iff {segment : OtsPrefix} {trace : Trace} {observed : Fin segment.digit.val → Digest → Option Digest}
+    (h : RowsObserved segment trace observed) (endpoint : Digest) :
+    SeenTwoEdge segment endpoint trace ↔ PartialChainEndpoint.TwoEdgeEvent observed endpoint := by
+  dsimp only [RowsObserved] at h
+  simp only [SeenTwoEdge, h, PartialChainEndpoint.twoEdgeEvent_iff_rows]
+
+end SphincsSecurity.Concrete.OtsContactTrace
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/OtsVerifierWitness.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsVerifierWitness.lean
new file mode 100644
index 000000000..aae634e2b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/OtsVerifierWitness.lean
@@ -0,0 +1,115 @@
+import SphincsSecurity.Proof.Ots.OtsChainBackward
+import SphincsSecurity.Proof.Ots.OtsEncodingMarker
+import SphincsSecurity.Proof.Hypertree.GraphPayloadInputs
+namespace SphincsSecurity.Concrete.OtsVerifierWitness
+
+open _root_.OracleComp OracleSpec OtsContactTrace
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] chainWalk canonicalEncodingInputs canonicalPayloadInputs
+
+variable (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (words : OtsReferenceWords)
+  (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (secret : ChainIndex → Digest)
+
+abbrev segment (index : ChainIndex) : OtsPrefix := OtsPrefix.atAddress parameter words ⟨lay, tree, leaf, index⟩
+
+def frontier (index : ChainIndex) : Digest := honestChain f parameter lay tree leaf index (secret index) (words lay tree leaf index).val
+
+def ChainException (trace : Trace) : Prop :=
+  (∃ index, ForwardChainMatch f (segment parameter words lay tree leaf index) (secret index) trace) ∨
+  (∃ index, SeenTwoEdge (segment parameter words lay tree leaf index) (frontier f parameter words lay tree leaf secret index) trace) ∨
+  (∃ left right, left ≠ right ∧
+    Seen (segment parameter words lay tree leaf left) (frontier f parameter words lay tree leaf secret left) trace ∧
+    Seen (segment parameter words lay tree leaf right) (frontier f parameter words lay tree leaf secret right) trace) ∨
+  (∃ index, OtsEncodingMarker.Seen parameter words ⟨lay, tree, leaf, index⟩ trace ∧
+    Seen (segment parameter words lay tree leaf index) (frontier f parameter words lay tree leaf secret index) trace)
+
+theorem otsLeaf_chain_run (message : Digest) (counter : Counter) (values : ChainIndex → Digest) (candidate : Encoding) (trace : Trace)
+    (hencode : evalWithAnswerFn f (encode parameter lay tree leaf message counter) = some candidate)
+    (hrun : ContainsRun f trace (otsLeaf parameter lay tree leaf message counter values)) (index : ChainIndex) :
+    ContainsRun f trace (recoverChain parameter lay tree leaf index (candidate index) (values index)) := by
+  have htail := hrun.bind_right
+  rw [hencode] at htail
+  exact ContainsRun.sequenceFin_component _ htail.bind_left index
+
+theorem otsLeaf_marker (message : Digest) (counter : Counter) (values : ChainIndex → Digest) (candidate : Encoding) (trace : Trace)
+    (hencode : evalWithAnswerFn f (encode parameter lay tree leaf message counter) = some candidate)
+    (hrun : ContainsRun f trace (otsLeaf parameter lay tree leaf message counter values))
+    (index : ChainIndex) (hneighbor : TargetSum.UnitNeighborAt (words lay tree leaf) candidate index) :
+    OtsEncodingMarker.Seen parameter words ⟨lay, tree, leaf, index⟩ trace := by
+  let input := tweakableHashInput parameter (.encoding lay tree leaf) (digestBytes message ++ counterBytes counter)
+  have hi : input ∈ queriedInputs f (encode parameter lay tree leaf message counter) := by
+    simp only [encode, queriedInputs_bind, queriedInputs_tweakableHash, queriedInputs_pure,
+      List.append_nil, List.mem_singleton, input]
+  refine ⟨(input, f input), hrun.bind_left input hi, ?_⟩
+  apply (OtsEncodingMarker.entryMarker_encoding_iff parameter words ⟨lay, tree, leaf, index⟩ message counter (f input)).mpr
+  refine ⟨candidate, ?_, hneighbor⟩
+  simpa only [encode, evalWithAnswerFn_bind, eval_tweakableHash, evalWithAnswerFn_pure, decodeEncodingOutput, input] using hencode
+
+theorem otsLeaf_chain_classification (message : Digest) (counter : Counter) (values : ChainIndex → Digest)
+    (candidate : Encoding) (trace : Trace) (hvalid : TargetSum.Valid (words lay tree leaf))
+    (hencode : evalWithAnswerFn f (encode parameter lay tree leaf message counter) = some candidate)
+    (hrun : ContainsRun f trace (otsLeaf parameter lay tree leaf message counter values))
+    (hendpoints : ∀ index, evalWithAnswerFn f (recoverChain parameter lay tree leaf index (candidate index) (values index))
+      = honestChain f parameter lay tree leaf index (secret index) (chainLength - 1)) :
+    (candidate = words lay tree leaf ∧ ∀ index, values index = frontier f parameter words lay tree leaf secret index) ∨
+      ChainException f parameter words lay tree leaf secret trace := by
+  by_cases hforward : ∃ index, ForwardChainMatch f (segment parameter words lay tree leaf index) (secret index) trace
+  · exact Or.inr (Or.inl hforward)
+  have hn (index : ChainIndex) : ¬ForwardChainMatch f (segment parameter words lay tree leaf index) (secret index) trace :=
+    fun h => hforward ⟨index, h⟩
+  have hc (index : ChainIndex) := otsLeaf_chain_run f parameter lay tree leaf message counter values candidate trace hencode hrun index
+  have hf (index : ChainIndex) (hb : (candidate index).val ≤ (words lay tree leaf index).val) :
+      walkValue f parameter lay tree leaf index (candidate index).val (values index)
+        ((words lay tree leaf index).val - (candidate index).val) = frontier f parameter words lay tree leaf secret index :=
+    recover_frontier f (segment parameter words lay tree leaf index) (secret index) (values index) (candidate index) trace hb
+      (hendpoints index) (hc index) (hn index)
+  have hcontact (index : ChainIndex) (hb : (candidate index).val < (words lay tree leaf index).val) :
+      Seen (segment parameter words lay tree leaf index) (frontier f parameter words lay tree leaf secret index) trace :=
+    recover_contact f (segment parameter words lay tree leaf index) (values index) (candidate index) trace hb _ (hf index (Nat.le_of_lt hb)) (hc index)
+  have hcandidate := valid_of_eval_encode_eq_some f parameter lay tree leaf message counter candidate hencode
+  rcases TargetSum.valid_encoding_classification hvalid hcandidate with heq | ⟨index, hneighbor⟩ | ⟨index, hlarge⟩ | ⟨left, right, hne, hl, hr⟩
+  · refine Or.inl ⟨heq.symm, ?_⟩
+    intro index
+    have hd := congrArg (fun word : Encoding => word index) heq
+    simpa only [frontier, hd] using recover_value f (segment parameter words lay tree leaf index) (secret index) (values index)
+      (candidate index) trace (by change (words lay tree leaf index).val ≤ (candidate index).val; rw [hd]) (hendpoints index) (hc index) (hn index)
+  · refine Or.inr (Or.inr (Or.inr (Or.inr ⟨index,
+      otsLeaf_marker f parameter words lay tree leaf message counter values candidate trace hencode hrun index hneighbor, ?_⟩)))
+    obtain ⟨raised, _, hlower, _⟩ := hneighbor
+    exact hcontact index (by omega)
+  · exact Or.inr (Or.inr (Or.inl ⟨index,
+      recover_twoEdge f (segment parameter words lay tree leaf index) (values index) (candidate index) trace hlarge _
+        (hf index (by omega)) (hc index)⟩))
+  · exact Or.inr (Or.inr (Or.inr (Or.inl ⟨left, right, hne, hcontact left hl, hcontact right hr⟩)))
+
+def canonicalLeaf : Digest := evalWithAnswerFn f (leafHash parameter lay tree leaf
+  (fun index => honestChain f parameter lay tree leaf index (secret index) (chainLength - 1)))
+
+def LeafOutputMatch (trace : Trace) : Prop :=
+  ∃ payload, payload ∈ canonicalPayloadInputs ∧ payload ≠ leafPayload (fun index => honestChain f parameter lay tree leaf index (secret index) (chainLength - 1)) ∧
+    (tweakableHashInput parameter (.leaf lay tree leaf) payload, f (tweakableHashInput parameter (.leaf lay tree leaf) payload)) ∈ trace.toList ∧
+    truncateHash (f (tweakableHashInput parameter (.leaf lay tree leaf) payload)) = canonicalLeaf f parameter lay tree leaf secret
+
+theorem otsLeaf_classification (message : Digest) (counter : Counter) (values : ChainIndex → Digest)
+    (candidate : Encoding) (trace : Trace) (hvalid : TargetSum.Valid (words lay tree leaf))
+    (hencode : evalWithAnswerFn f (encode parameter lay tree leaf message counter) = some candidate)
+    (hrun : ContainsRun f trace (otsLeaf parameter lay tree leaf message counter values))
+    (hleaf : evalWithAnswerFn f (otsLeaf parameter lay tree leaf message counter values)
+      = some (canonicalLeaf f parameter lay tree leaf secret)) :
+    (candidate = words lay tree leaf ∧ ∀ index, values index = frontier f parameter words lay tree leaf secret index) ∨
+      LeafOutputMatch f parameter lay tree leaf secret trace ∨ ChainException f parameter words lay tree leaf secret trace := by
+  let endpoints := fun index => evalWithAnswerFn f (recoverChain parameter lay tree leaf index (candidate index) (values index))
+  have heval : evalWithAnswerFn f (leafHash parameter lay tree leaf endpoints) = canonicalLeaf f parameter lay tree leaf secret := by
+    simpa only [otsLeaf, evalWithAnswerFn_bind, hencode, evalWithAnswerFn_sequenceFin, evalWithAnswerFn_pure,
+      Option.some.injEq, endpoints] using hleaf
+  by_cases hp : leafPayload endpoints = leafPayload (fun index => honestChain f parameter lay tree leaf index (secret index) (chainLength - 1))
+  · have hs := otsLeaf_chain_classification f parameter words lay tree leaf secret message counter values candidate trace hvalid hencode hrun
+      (fun index => congrFun (TargetSum.leafPayload_injective hp) index)
+    exact hs.imp_right Or.inr
+  · refine Or.inr (Or.inl ⟨leafPayload endpoints, leafPayload_mem_canonicalPayloadInputs endpoints, hp, ?_, ?_⟩)
+    · apply hrun
+      exact otsLeaf_leaf_query_mem f parameter lay tree leaf message counter values candidate hencode
+    · simpa only [leafHash, eval_tweakableHash] using heval
+
+end SphincsSecurity.Concrete.OtsVerifierWitness
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/PrefixByteAction.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/PrefixByteAction.lean
new file mode 100644
index 000000000..f8786c07a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/PrefixByteAction.lean
@@ -0,0 +1,83 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Ots.ReferencePrefixResidual
+import SphincsSecurity.Proof.Residual.ResidualByteAction
+namespace SphincsSecurity.Concrete.ResidualByteAction
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting HiddenLabelObservation
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def freshPrefix (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels) (publicReplies : CanonicalGraphLabels)
+    (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (input : inputs) : Action inputs :=
+  match route parameter words disclosed known input.val with
+  | .outside => (knownEncodingRowAt parameter inputs hencoding known input).elim (.read input)
+      (fun row => if FirstSuccessPrefix.familyKept selections row then .known (rows row) else .read input)
+  | .canonical position => .known (publicReplies position)
+  | .probe test => .probe input test
+
+theorem freshPrefix_local (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels) (publicReplies : CanonicalGraphLabels)
+    (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (input : inputs) :
+    Local input (freshPrefix parameter inputs hencoding words disclosed known publicReplies selections rows input) := by
+  unfold freshPrefix
+  cases route parameter words disclosed known input.val with
+  | outside =>
+      cases knownEncodingRowAt parameter inputs hencoding known input with
+      | none => rfl
+      | some row => simp only [Option.elim_some]; split <;> trivial
+  | canonical _ => trivial
+  | probe _ => rfl
+
+theorem freshPrefix_eq_routed (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known actual : Labels)
+    (hagrees : PublicAgreement words disclosed known actual) (publicReplies : CanonicalGraphLabels)
+    (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (seed : inputs → HashOutput) (input : inputs) :
+    eval actual seed (freshPrefix parameter inputs hencoding words disclosed known publicReplies selections rows input) =
+      routedTableReply publicReplies actual
+        (finiteHashAnswer ∅ inputs (knownPrefixResidual parameter inputs hencoding known selections rows seed)) input.val
+        (route parameter words disclosed known input.val) := by
+  have hspec := route_spec parameter words disclosed known actual hagrees input.val
+  rw [freshPrefix]
+  cases hroute : route parameter words disclosed known input.val with
+  | outside =>
+      rw [routedTableReply, finiteHashAnswer_none ∅ inputs _ input.val input.property (by simp), knownPrefixResidual_lookup]
+      cases knownEncodingRowAt parameter inputs hencoding known input with
+      | none => rfl
+      | some row => simp only [Option.elim_some]; split <;> rfl
+  | canonical position => rfl
+  | probe test =>
+      rw [hroute] at hspec
+      have hat : ∃ position, AtPosition parameter input.val position := by
+        cases test with
+        | pair child parent hne candidate => exact ⟨hspec.choose, hspec.choose_spec.1⟩
+        | output parent => exact ⟨hspec.choose, hspec.choose_spec.1⟩
+      obtain ⟨position, hat⟩ := hat
+      rw [routedTableReply, finiteHashAnswer_none ∅ inputs _ input.val input.property (by simp),
+        knownPrefixResidual_structural parameter inputs hencoding known selections rows seed input position hat]
+      rfl
+
+theorem freshPrefix_eq_original (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (replies publicReplies : CanonicalGraphLabels)
+    (hagrees : PublicAgreement words disclosed known (CanonicalCoordinate.value otsSecret ftsSecret replies))
+    (hreplies : ∀ position, ¬CanonicalCoordinate.Hidden words disclosed (.graph position) → publicReplies position = replies position)
+    (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (seed : inputs → HashOutput) (input : inputs) :
+    let actual := CanonicalCoordinate.value otsSecret ftsSecret replies
+    let answer := programmedHash parameter otsSecret ftsSecret replies
+      (finiteHashAnswer ∅ inputs (canonicalPrefixResidual parameter inputs hencoding replies selections rows seed)) input.val
+    eval actual seed (freshPrefix parameter inputs hencoding words disclosed known publicReplies selections rows input) =
+      if CanonicalProbeRouting.Bad parameter words disclosed actual input.val answer then none else some answer := by
+  dsimp only
+  rw [freshPrefix_eq_routed parameter inputs hencoding words disclosed known _ hagrees publicReplies selections rows seed input,
+    ← stoppedTableReply_route parameter words disclosed known _ hagrees replies publicReplies hreplies,
+    stoppedTableReply, tableReply_programmed,
+    canonicalPrefixResidual_eq_known parameter inputs hencoding words disclosed known otsSecret ftsSecret replies hagrees]
+
+end SphincsSecurity.Concrete.ResidualByteAction
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/PrefixByteRun.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/PrefixByteRun.lean
new file mode 100644
index 000000000..7cca11d72
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/PrefixByteRun.lean
@@ -0,0 +1,19 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.CheckedByteExecution
+import SphincsSecurity.Proof.Ots.PrefixByteAction
+import SphincsSecurity.Proof.Ots.PublicEncodingMatch
+namespace SphincsSecurity.Concrete.ResidualByteFrontend
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting HiddenLabelObservation ResidualByteAction
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable abbrev prefixEnvironment (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels) (publicReplies : CanonicalGraphLabels)
+    (selections : ReferenceFamily) (rows : CanonicalEncodingRows) :=
+  environment parameter inputs words disclosed known
+    (freshPrefix parameter inputs hencoding words disclosed known publicReplies selections rows)
+
+end SphincsSecurity.Concrete.ResidualByteFrontend
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/PrefixEncodingRisk.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/PrefixEncodingRisk.lean
new file mode 100644
index 000000000..f744a2671
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/PrefixEncodingRisk.lean
@@ -0,0 +1,208 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Ots.PrefixByteRun
+import SphincsSecurity.Proof.Reference.ReferenceJointPrior
+namespace SphincsSecurity.Concrete.ResidualByteFrontend
+
+open _root_.OracleComp OracleSpec ENNReal CanonicalProbeRouting HiddenLabelObservation ResidualByteAction
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+def ReplyClean (reject : HashInput → HashOutput → Prop) (cache : ExternalCache) : Prop :=
+  ∀ input answer, cache input = some answer → ¬reject input answer
+
+theorem replyClean_empty (reject : HashInput → HashOutput → Prop) : ReplyClean reject (fun _ => none) := by
+  intro input answer hcache
+  cases hcache
+
+theorem replyClean_store (reject : HashInput → HashOutput → Prop) (cache : ExternalCache)
+    (hclean : ReplyClean reject cache) (input : HashInput) (answer : HashOutput) (hsafe : ¬reject input answer) :
+    ReplyClean reject (Function.update cache input (some answer)) := by
+  intro other value hcache
+  by_cases heq : other = input
+  · subst other
+    rw [Function.update_self, Option.some.injEq] at hcache
+    subst value
+    exact hsafe
+  · rw [Function.update_of_ne heq] at hcache
+    exact hclean other value hcache
+
+theorem checkedFixedStep_replyClean (parameter : PublicParameter) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known actual : Labels)
+    (reject : HashInput → HashOutput → Prop) (oracle : HashInput → HashOutput)
+    (input : HashInput) (memory : ExternalMemory) (hclean : ReplyClean reject memory.cache)
+    (answer : HashOutput)
+    (hanswer : (checkedResult reject input (fixedStep parameter words disclosed known actual oracle input memory)).1 = some answer) :
+    ReplyClean reject (checkedResult reject input (fixedStep parameter words disclosed known actual oracle input memory)).2.cache := by
+  unfold checkedResult fixedStep at hanswer ⊢
+  cases hfixed : fixedAnswer parameter words disclosed actual oracle input with
+  | none => simp only [hfixed, Option.bind_none, reduceCtorEq] at hanswer
+  | some output =>
+      simp only [hfixed, Option.bind_some, Option.elim_some] at hanswer ⊢
+      split at hanswer
+      · contradiction
+      · rename_i hsafe
+        exact replyClean_store reject memory.cache hclean input output hsafe
+
+def ReturnedMatch {Memory : Type} (reject : HashInput → HashOutput → Prop) (input : HashInput)
+    (result : Option HashOutput × Memory) : Prop :=
+  ∃ answer, result.1 = some answer ∧ reject input answer
+
+theorem returnedMatch_some {Memory : Type} (reject : HashInput → HashOutput → Prop)
+    (input : HashInput) (answer : HashOutput) (memory : Memory) :
+    ReturnedMatch reject input (some answer, memory) ↔ reject input answer := by
+  simp [ReturnedMatch]
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels) (actions : inputs → Action inputs)
+
+theorem lazyRun_prepare_bind {Result : Type} (input : inputs)
+    (next : Action inputs → OracleComp (World inputs) Result) (state : State inputs) :
+    AdaptiveResidualLabels.lazyRun (environment parameter inputs words disclosed known actions)
+      (liftM ((World inputs).query (.inl (.prepare input))) >>= next) state =
+        let prepared := prepare parameter inputs words disclosed known actions input state.memory
+        AdaptiveResidualLabels.lazyRun (environment parameter inputs words disclosed known actions)
+          (next prepared.1) { state with memory := prepared.2 } := by
+  rw [AdaptiveResidualLabels.lazyRun, AdaptiveResidualLabels.runWith_query_bind]
+  simp only [AdaptiveResidualLabels.lazyImpl, environment, OptionT.run_mk, StateT.run_mk,
+    SPMF.lift_pure, pure_bind, Option.elim_some, AdaptiveResidualLabels.lazyRun]
+
+theorem lazyRun_execute_known (answer : HashOutput) (state : State inputs) :
+    AdaptiveResidualLabels.lazyRun (environment parameter inputs words disclosed known actions)
+      (execute (.known answer)) state = pure (some answer, state) := by
+  exact AdaptiveResidualLabels.runWith_pure _ answer state
+
+theorem lazyRun_execute_read (input : inputs) (state : State inputs) :
+    AdaptiveResidualLabels.lazyRun (environment parameter inputs words disclosed known actions)
+      (execute (.read input)) state =
+        (fun answer => (some answer, AdaptiveResidualLabels.readState
+          (environment parameter inputs words disclosed known actions) state input answer)) <$>
+          ResidualTableCompletion.reply state.rows input := by
+  simp only [AdaptiveResidualLabels.lazyRun, execute, AdaptiveResidualLabels.runWith, simulateQ_spec_query,
+    AdaptiveResidualLabels.lazyImpl, OptionT.run_mk, StateT.run_mk, map_eq_bind_pure_comp, Function.comp_def]
+
+theorem lazyImpl_rowsCovered (input : (World inputs).Domain) (state : State inputs) (hcovered : RowsCovered inputs state)
+    (result : Option ((World inputs).Range input) × State inputs)
+    (hresult : (AdaptiveResidualLabels.lazyImpl (environment parameter inputs words disclosed known actions) input).run.run state result ≠ 0) :
+    RowsCovered inputs result.2 := by
+  cases input with
+  | inl input =>
+      cases input with
+      | prepare input =>
+          simp only [AdaptiveResidualLabels.lazyImpl, environment, OptionT.run_mk, StateT.run_mk,
+            SPMF.lift_pure, pure_bind, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          subst result
+          exact prepare_rowsCovered parameter inputs words disclosed known actions state hcovered input
+      | random input =>
+          simp only [AdaptiveResidualLabels.lazyImpl, environment, OptionT.run_mk, StateT.run_mk,
+            ← PMF.monad_map_eq_map, liftM_map, bind_map_left] at hresult
+          obtain ⟨answer, _, hresult⟩ := (RetainedObservation.bind_nonzero _ _ _).mp hresult
+          simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          subst result
+          exact hcovered
+      | stop =>
+          simp only [AdaptiveResidualLabels.lazyImpl, environment, OptionT.run_mk, StateT.run_mk,
+            SPMF.lift_pure, pure_bind, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          subst result
+          exact hcovered
+      | account cost =>
+          simp only [AdaptiveResidualLabels.lazyImpl, environment, OptionT.run_mk, StateT.run_mk,
+            SPMF.lift_pure, pure_bind, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          subst result
+          exact hcovered
+  | inr input =>
+      cases input with
+      | read input =>
+          simp only [AdaptiveResidualLabels.lazyImpl, OptionT.run_mk, StateT.run_mk] at hresult
+          obtain ⟨answer, _, hresult⟩ := (RetainedObservation.bind_nonzero _ _ _).mp hresult
+          simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          subst result
+          exact rowsCovered_store inputs state hcovered state.candidates input answer
+      | probe input test =>
+          simp only [AdaptiveResidualLabels.lazyImpl, OptionT.run_mk, StateT.run_mk] at hresult
+          cases hrow : state.rows input with
+          | some answer =>
+              simp only [hrow, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+              subst result
+              exact rowsCovered_store inputs state hcovered state.candidates input answer
+          | none =>
+              rw [hrow] at hresult
+              rcases (RetainedObservation.observe_nonzero _ _ _ _).mp hresult with ⟨_, hstop⟩ | ⟨answer, _, hnext⟩
+              · simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hstop
+                subst result
+                exact hcovered
+              · simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hnext
+                subst result
+                exact rowsCovered_store inputs state hcovered (test.restrict state.candidates answer) input answer
+      | disclose coordinate =>
+          simp only [AdaptiveResidualLabels.lazyImpl, OptionT.run_mk, StateT.run_mk] at hresult
+          obtain ⟨value, _, hresult⟩ := (RetainedObservation.bind_nonzero _ _ _).mp hresult
+          simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          subst result
+          exact hcovered
+
+omit actions in
+theorem prefix_encoding_actions (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+    (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+    (hselect : ∀ position, FirstSuccessTable.select decodeEncodingOutput (fun counter => rows (position, counter)) = selections position)
+    (input : inputs) (position : EncodingPosition) (hat : AtEncodingPosition parameter input.val position) :
+    (∃ answer, freshPrefix parameter inputs hencoding words disclosed known publicReplies selections rows input = .known answer ∧
+      ¬PublicEncodingMatch.Match parameter (knownEncodingMessage known) words selections input.val answer) ∨
+    freshPrefix parameter inputs hencoding words disclosed known publicReplies selections rows input = .read input := by
+  have hroute : route parameter words disclosed known input.val = .outside := by
+    rw [route, (decodePosition_none_iff parameter input.val).mpr (fun other => hat.not_atPosition other)]
+    rfl
+  unfold freshPrefix
+  rw [hroute]
+  cases hrow : knownEncodingRowAt parameter inputs hencoding known input with
+  | none => exact Or.inr rfl
+  | some row =>
+      simp only [Option.elim_some]
+      by_cases hkept : FirstSuccessPrefix.familyKept selections row
+      · simp only [if_pos hkept]
+        apply Or.inl
+        refine ⟨rows row, rfl, ?_⟩
+        have heq := (knownEncodingRowAt_some parameter inputs hencoding known input row).mp hrow
+        rw [← heq]
+        exact PublicEncodingMatch.protected_not_match parameter inputs hencoding known words selections rows row (hselect row.1) hkept
+      · exact Or.inr (if_neg hkept)
+
+omit actions in
+theorem prob_prefixHashQuery_encodingMatch_le (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+    (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+    (hselect : ∀ position, FirstSuccessTable.select decodeEncodingOutput (fun counter => rows (position, counter)) = selections position)
+    (input : inputs) (state : State inputs) (hcovered : RowsCovered inputs state)
+    (hclean : ReplyClean (PublicEncodingMatch.Match parameter (knownEncodingMessage known) words selections) state.memory.cache) :
+    Pr[ReturnedMatch (PublicEncodingMatch.Match parameter (knownEncodingMessage known) words selections) input.val |
+      AdaptiveResidualLabels.lazyRun
+        (prefixEnvironment parameter inputs hencoding words disclosed known publicReplies selections rows) (hashQuery input) state] ≤
+      (Fintype.card Digest : ENNReal)⁻¹ := by
+  by_cases hexists : ∃ position, AtEncodingPosition parameter input.val position
+  · obtain ⟨position, hat⟩ := hexists
+    rw [hashQuery, lazyRun_prepare_bind]
+    cases hcache : state.memory.cache input.val with
+    | some answer =>
+        rw [prepare_cached parameter inputs words disclosed known _ input state.memory answer hcache, lazyRun_execute_known]
+        simp only [probEvent_pure, returnedMatch_some, if_neg (hclean input.val answer hcache), zero_le]
+    | none =>
+        have hfresh := rowsCovered_fresh inputs state hcovered input hcache
+        rcases prefix_encoding_actions parameter inputs words disclosed known hencoding publicReplies selections rows hselect input position hat with
+          ⟨answer, haction, hsafe⟩ | haction
+        · simp only [prepare, hcache, haction]
+          rw [lazyRun_execute_known]
+          simp only [probEvent_pure, returnedMatch_some, if_neg hsafe, zero_le]
+        · simp only [prepare, hcache, haction]
+          rw [lazyRun_execute_read]
+          simp only [ResidualTableCompletion.reply, hfresh]
+          simpa only [probEvent_map, Function.comp_def, returnedMatch_some] using
+            PublicEncodingMatch.prob_match_le parameter (knownEncodingMessage known) words selections input.val
+  · have hzero : Pr[ReturnedMatch (PublicEncodingMatch.Match parameter (knownEncodingMessage known) words selections) input.val |
+        AdaptiveResidualLabels.lazyRun
+          (prefixEnvironment parameter inputs hencoding words disclosed known publicReplies selections rows) (hashQuery input) state] = 0 := by
+      apply probEvent_eq_zero
+      rintro result _ ⟨answer, _, position, hat, _⟩
+      exact hexists ⟨position, hat⟩
+    rw [hzero]
+    exact bot_le
+
+end SphincsSecurity.Concrete.ResidualByteFrontend
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/PublicEncodingMatch.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/PublicEncodingMatch.lean
new file mode 100644
index 000000000..5e67f970c
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/PublicEncodingMatch.lean
@@ -0,0 +1,95 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Base.FirstSuccessPrefix
+import SphincsSecurity.Proof.Fts.HiddenLabelProbe
+import SphincsSecurity.Proof.Ots.OtsProbeCompletionSampling
+import SphincsSecurity.Proof.Ots.OtsProbeOrigin
+import SphincsSecurity.Proof.Fts.FtsProbeSampling
+import SphincsSecurity.Proof.Base.RomQueryChargeBind
+import SphincsSecurity.Proof.Residual.PublicReferenceResidual
+namespace SphincsSecurity.Concrete.PublicEncodingMatch
+
+open _root_.OracleComp OracleSpec ENNReal CanonicalProbeRouting
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+def referenceInput (parameter : PublicParameter) (messages : EncodingPosition → Digest)
+    (selections : ReferenceFamily) (position : EncodingPosition) : Option HashInput :=
+  (selections position).map (fun selected => encodingRetryInput parameter position (messages position) selected.1.val)
+
+def Match (parameter : PublicParameter) (messages : EncodingPosition → Digest)
+    (words : OtsReferenceWords) (selections : ReferenceFamily) (input : HashInput) (answer : HashOutput) : Prop :=
+  ∃ position, AtEncodingPosition parameter input position ∧
+    referenceInput parameter messages selections position ≠ some input ∧
+    decodeEncodingOutput answer = some (words position.lay position.tree position.leafIdx)
+
+theorem known_eq_original (parameter : PublicParameter) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (labels : CanonicalGraphLabels)
+    (hagrees : PublicAgreement words disclosed known (CanonicalCoordinate.value otsSecret ftsSecret labels))
+    (selections : ReferenceFamily) :
+    Match parameter (knownEncodingMessage known) words selections =
+      Match parameter (canonicalGraphMessage labels) words selections := by
+  rw [knownEncodingMessage_eq words disclosed known otsSecret ftsSecret labels hagrees]
+
+theorem protected_not_match (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (known : Labels)
+    (words : OtsReferenceWords) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+    (row : EncodingRow)
+    (hselect : FirstSuccessTable.select decodeEncodingOutput (fun counter => rows (row.1, counter)) = selections row.1)
+    (hkept : FirstSuccessPrefix.familyKept selections row) :
+    ¬Match parameter (knownEncodingMessage known) words selections
+      (knownEncodingCell parameter inputs hencoding known row).val (rows row) := by
+  rintro ⟨position, hat, hnonreference, hdecode⟩
+  have hrow : AtEncodingPosition parameter (knownEncodingCell parameter inputs hencoding known row).val row.1 := ⟨_, rfl⟩
+  obtain rfl := atEncodingPosition_unique hat hrow
+  have hnot : (selections row.1).map Prod.fst ≠ some row.2 := by
+    intro heq
+    apply hnonreference
+    unfold referenceInput
+    cases hselected : selections row.1 with
+    | none => simp only [hselected, Option.map_none, reduceCtorEq] at heq
+    | some selected =>
+        have hcounter : selected.1 = row.2 := by simpa only [hselected, Option.map_some, Option.some.injEq] using heq
+        simp only [Option.map_some, hcounter]
+        rfl
+  have hinvalid := FirstSuccessPrefix.kept_nonselected_invalid decodeEncodingOutput
+    (fun counter => rows (row.1, counter)) (selections row.1) hselect row.2 hkept hnot
+  rw [hdecode] at hinvalid
+  contradiction
+
+theorem prob_decode_word_le (word : Encoding) :
+    Pr[fun answer => decodeEncodingOutput answer = some word | (liftM (PMF.uniformOfFintype HashOutput) : SPMF HashOutput)] ≤
+      (Fintype.card Digest : ENNReal)⁻¹ := by
+  by_cases hexists : ∃ digest, TargetSum.decodeDigest digest = some word
+  · obtain ⟨digest, hdigest⟩ := hexists
+    calc
+      _ ≤ Pr[fun answer => truncateHash answer = digest |
+          (liftM (PMF.uniformOfFintype HashOutput) : SPMF HashOutput)] :=
+        probEvent_mono fun _ _ hdecode => TargetSum.decodeDigest_some_injective hdecode hdigest
+      _ = _ := HiddenLabelProbe.prob_truncate_eq digest
+  · have hfalse (answer : HashOutput) : ¬decodeEncodingOutput answer = some word :=
+      fun hdecode => hexists ⟨truncateHash answer, hdecode⟩
+    simp only [probEvent_eq_tsum_ite, hfalse, if_false, tsum_zero, zero_le]
+
+theorem prob_match_le (parameter : PublicParameter) (messages : EncodingPosition → Digest)
+    (words : OtsReferenceWords) (selections : ReferenceFamily) (input : HashInput) :
+    Pr[Match parameter messages words selections input | (liftM (PMF.uniformOfFintype HashOutput) : SPMF HashOutput)] ≤
+      (Fintype.card Digest : ENNReal)⁻¹ := by
+  by_cases hexists : ∃ position, AtEncodingPosition parameter input position
+  · obtain ⟨position, hat⟩ := hexists
+    calc
+      _ ≤ Pr[fun answer => decodeEncodingOutput answer = some (words position.lay position.tree position.leafIdx) |
+          (liftM (PMF.uniformOfFintype HashOutput) : SPMF HashOutput)] := by
+        apply probEvent_mono
+        rintro answer _ ⟨other, hother, _, hdecode⟩
+        obtain rfl := atEncodingPosition_unique hother hat
+        exact hdecode
+      _ ≤ _ := prob_decode_word_le _
+  · have hfalse (answer : HashOutput) : ¬Match parameter messages words selections input answer := by
+      rintro ⟨position, hat, _⟩
+      exact hexists ⟨position, hat⟩
+    simp only [probEvent_eq_tsum_ite, hfalse, if_false, tsum_zero, zero_le]
+
+end SphincsSecurity.Concrete.PublicEncodingMatch
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceEncodingContext.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceEncodingContext.lean
new file mode 100644
index 000000000..17f65a03e
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceEncodingContext.lean
@@ -0,0 +1,91 @@
+import SphincsSecurity.Proof.Ots.ReferenceEncodingLazySource
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec UniformTableCompletion
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs Finset.univ referenceEncodingRest
+
+abbrev EncodingContextResult (Result : Type) := PublicParameter × ReferenceFamily × (EncodingPosition → Digest) × Result
+
+noncomputable def referenceEncodingContextRest {Result : Type} (observer : FrontierObserver Result)
+    (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) : SPMF (ReferenceFamily × (EncodingPosition → Digest) × Result) := do
+  let reference ← 𝒟[referenceFamilyOracleSample key inputs hencoding]
+  let oracle := finiteHashAnswer ∅ inputs reference.2
+  let labels := canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret oracle
+  let result ← 𝒟[referenceInstrumentedRest observer key oracle labels reference.1 dummy adversary]
+  pure (reference.1, canonicalGraphMessage labels, result)
+
+theorem referenceEncodingContextRest_lazy {Result : Type} (observer : FrontierObserver Result)
+    (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+    (hgraph : canonicalGraphInputs key.parameter ⊆ inputs) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    referenceEncodingContextRest observer key inputs hencoding dummy adversary = (do
+      let selections ← 𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit]
+      let outside ← 𝒟[PMF.uniformOfFintype (NonencodingRows key.parameter inputs hencoding)]
+      let result ← Prod.fst <$> referenceEncodingLazyRest observer key inputs hencoding outside selections dummy adversary
+      pure (selections, outsideGraphMessage key inputs hencoding outside, result)) := by
+  have hrest : referenceEncodingContextRest observer key inputs hencoding dummy adversary = (do
+      let reference ← 𝒟[referenceFamilyOracleSample key inputs hencoding]
+      let result ← 𝒟[referenceEncodingRest observer key inputs hencoding (fun cell => reference.2 cell.val)
+        reference.1 (reference.2 ∘ encodingInputCell key.parameter inputs hencoding) dummy adversary]
+      pure (reference.1, canonicalGraphMessage
+        (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret (finiteHashAnswer ∅ inputs reference.2)), result)) := by
+    unfold referenceEncodingContextRest
+    apply evalDist_bind_congr (m := SPMF)
+    intro reference hreference
+    have hselected := referenceFamilyOracleSample_selections key inputs hencoding hgraph reference
+      (by simpa only [PMF.evalDist_eq, SPMF.support_eq_support, SPMF.support_liftM] using hreference)
+    dsimp only
+    rw [referenceEncodingRest_table observer key inputs hencoding hgraph reference.1 reference.2 hselected.symm dummy adversary]
+  rw [hrest]
+  simp only [referenceFamilyOracleSample, ← PMF.monad_bind_eq_bind, ← PMF.monad_map_eq_map,
+    evalDist_bind, evalDist_map, bind_assoc, bind_map_left, referenceFamilyOracleTable,
+    referenceEncodingRest_join, canonicalGraphLabels_joinEncodingTable _ _ _ _ hencoding hgraph]
+  apply congrArg (𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit] >>= ·)
+  funext selections
+  apply congrArg (𝒟[PMF.uniformOfFintype (NonencodingRows key.parameter inputs hencoding)] >>= ·)
+  funext outside
+  have hmessages : canonicalGraphMessage (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret
+      (nonencodingAnswer key.parameter inputs hencoding outside)) = outsideGraphMessage key inputs hencoding outside := rfl
+  rw [hmessages]
+  have h := congrArg (fun law : SPMF Result => law >>= fun result =>
+    pure (selections, outsideGraphMessage key inputs hencoding outside, result))
+      (referenceEncodingLazyRest_original observer key inputs hencoding outside selections dummy adversary)
+  rw [← referenceEncodingPrior_complete] at h
+  simpa only [referenceEncodingPrior, ← PMF.monad_bind_eq_bind, ← PMF.monad_map_eq_map,
+    evalDist_bind, evalDist_map, bind_assoc, bind_map_left] using h
+
+noncomputable def referenceEncodingContextGame {Result : Type} (observer : FrontierObserver Result)
+    (inputs : Finset HashInput) (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) : SPMF (EncodingContextResult Result) := do
+  let parameter ← 𝒟[sampleParameter]
+  let otsSecret ← 𝒟[sampleOtsSecrets]
+  let ftsSecret ← 𝒟[sampleFtsSecrets]
+  let result ← referenceEncodingContextRest observer ⟨parameter, 0, otsSecret, ftsSecret⟩ inputs (hencoding parameter) dummy adversary
+  pure (parameter, result)
+
+theorem referenceEncodingContextGame_erased {Result : Type} (observer : FrontierObserver Result)
+    (inputs : Finset HashInput) (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (fun result : EncodingContextResult Result => (result.1, result.2.1, result.2.2.2)) <$>
+      referenceEncodingContextGame observer inputs hencoding dummy adversary =
+        referenceInstrumentedGame observer inputs hencoding dummy adversary := by
+  simp only [referenceEncodingContextGame, referenceEncodingContextRest, referenceInstrumentedGame,
+    map_bind, map_pure, bind_assoc, pure_bind]
+
+theorem referenceEncodingContextGame_lazy {Result : Type} (observer : FrontierObserver Result)
+    (inputs : Finset HashInput) (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    referenceEncodingContextGame observer inputs hencoding dummy adversary = (do
+      let parameter ← 𝒟[sampleParameter]
+      let otsSecret ← 𝒟[sampleOtsSecrets]
+      let ftsSecret ← 𝒟[sampleFtsSecrets]
+      let key : SecretKey := ⟨parameter, 0, otsSecret, ftsSecret⟩
+      let selections ← 𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit]
+      let outside ← 𝒟[PMF.uniformOfFintype (NonencodingRows parameter inputs (hencoding parameter))]
+      let result ← Prod.fst <$> referenceEncodingLazyRest observer key inputs (hencoding parameter) outside selections dummy adversary
+      pure (parameter, selections, outsideGraphMessage key inputs (hencoding parameter) outside, result)) := by
+  simp only [referenceEncodingContextGame, referenceEncodingContextRest_lazy observer _ inputs _ (hgraph _) dummy adversary,
+    bind_assoc, pure_bind]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceEncodingErasure.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceEncodingErasure.lean
new file mode 100644
index 000000000..dbb32ad47
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceEncodingErasure.lean
@@ -0,0 +1,107 @@
+import SphincsSecurity.Proof.Ots.ReferenceEncodingProgram
+import SphincsSecurity.Proof.Reference.ReferenceInstrumentedGame
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs
+
+noncomputable def referenceEncodingRepresentative (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+    (outside : NonencodingRows key.parameter inputs hencoding) (selections : ReferenceFamily) :
+    canonicalEncodingInputs key.parameter → HashOutput :=
+  if h : ∃ encoding, referenceTableSelection key
+      (finiteHashAnswer ∅ inputs (joinEncodingTable key.parameter inputs hencoding encoding outside)) = selections
+  then Classical.choose h else fun _ => 0
+
+theorem referenceEncodingRepresentative_selected (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+    (outside : NonencodingRows key.parameter inputs hencoding) (selections : ReferenceFamily)
+    (encoding : canonicalEncodingInputs key.parameter → HashOutput)
+    (hselected : referenceTableSelection key
+      (finiteHashAnswer ∅ inputs (joinEncodingTable key.parameter inputs hencoding encoding outside)) = selections) :
+    referenceTableSelection key (finiteHashAnswer ∅ inputs (joinEncodingTable key.parameter inputs hencoding
+      (referenceEncodingRepresentative key inputs hencoding outside selections) outside)) = selections := by
+  have hex : ∃ encoding, referenceTableSelection key
+      (finiteHashAnswer ∅ inputs (joinEncodingTable key.parameter inputs hencoding encoding outside)) = selections :=
+    ⟨encoding, hselected⟩
+  rw [referenceEncodingRepresentative, dif_pos hex]
+  exact Classical.choose_spec hex
+
+noncomputable def referenceEncodingProgram (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+    (outside : NonencodingRows key.parameter inputs hencoding) (selections : ReferenceFamily)
+    (dummy : OtsReferenceWords) (adversary : Adversary) : OracleComp OracleWorld (Bool × SigningBoundaryTrace) :=
+  let words := referenceFamilyWords selections dummy
+  let frontier := canonicalGraphFrontier key.otsSecret (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret
+    (nonencodingAnswer key.parameter inputs hencoding outside)) words
+  CausalFrontierProgram.game key.parameter
+    (finiteHashAnswer ∅ inputs (joinEncodingTable key.parameter inputs hencoding
+      (referenceEncodingRepresentative key inputs hencoding outside selections) outside)) key.ftsSecret words frontier adversary
+
+theorem referenceEncodingProgram_selected (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (hgraph : canonicalGraphInputs key.parameter ⊆ inputs)
+    (outside : NonencodingRows key.parameter inputs hencoding) (selections : ReferenceFamily)
+    (encoding : canonicalEncodingInputs key.parameter → HashOutput)
+    (hselected : referenceTableSelection key
+      (finiteHashAnswer ∅ inputs (joinEncodingTable key.parameter inputs hencoding encoding outside)) = selections)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    let words := referenceFamilyWords selections dummy
+    let frontier := canonicalGraphFrontier key.otsSecret (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret
+      (nonencodingAnswer key.parameter inputs hencoding outside)) words
+    CausalFrontierProgram.game key.parameter
+        (finiteHashAnswer ∅ inputs (joinEncodingTable key.parameter inputs hencoding encoding outside))
+        key.ftsSecret words frontier adversary =
+      referenceEncodingProgram key inputs hencoding outside selections dummy adversary :=
+  joinedEncoding_program_eq key inputs hencoding hgraph encoding _ outside selections hselected
+    (referenceEncodingRepresentative_selected key inputs hencoding outside selections encoding hselected) dummy adversary
+
+noncomputable def referenceEncodingRest {Result : Type} (observer : FrontierObserver Result)
+    (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+    (outside : NonencodingRows key.parameter inputs hencoding) (selections : ReferenceFamily)
+    (encoding : canonicalEncodingInputs key.parameter → HashOutput)
+    (dummy : OtsReferenceWords) (adversary : Adversary) : ProbComp Result :=
+  let words := referenceFamilyWords selections dummy
+  let frontier := canonicalGraphFrontier key.otsSecret (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret
+    (nonencodingAnswer key.parameter inputs hencoding outside)) words
+  simulateQ (fixedHashWorld (finiteHashAnswer ∅ inputs (joinEncodingTable key.parameter inputs hencoding encoding outside)))
+    (observer key.parameter words frontier (referenceEncodingProgram key inputs hencoding outside selections dummy adversary))
+
+theorem referenceEncodingRest_selected {Result : Type} (observer : FrontierObserver Result)
+    (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+    (hgraph : canonicalGraphInputs key.parameter ⊆ inputs)
+    (outside : NonencodingRows key.parameter inputs hencoding) (selections : ReferenceFamily)
+    (encoding : canonicalEncodingInputs key.parameter → HashOutput)
+    (hselected : referenceTableSelection key
+      (finiteHashAnswer ∅ inputs (joinEncodingTable key.parameter inputs hencoding encoding outside)) = selections)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    let oracle := finiteHashAnswer ∅ inputs (joinEncodingTable key.parameter inputs hencoding encoding outside)
+    referenceInstrumentedRest observer key oracle (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret oracle)
+        selections dummy adversary =
+      referenceEncodingRest observer key inputs hencoding outside selections encoding dummy adversary := by
+  dsimp only
+  rw [referenceInstrumentedRest, canonicalGraphLabels_joinEncodingTable _ _ _ _ hencoding hgraph]
+  rw [referenceEncodingProgram_selected key inputs hencoding hgraph outside selections encoding hselected]
+  rfl
+
+theorem referenceEncodingRest_table {Result : Type} (observer : FrontierObserver Result)
+    (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+    (hgraph : canonicalGraphInputs key.parameter ⊆ inputs) (selections : ReferenceFamily)
+    (table : inputs → HashOutput) (hselected : referenceTableSelection key (finiteHashAnswer ∅ inputs table) = selections)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    referenceInstrumentedRest observer key (finiteHashAnswer ∅ inputs table)
+        (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret (finiteHashAnswer ∅ inputs table)) selections dummy adversary =
+      referenceEncodingRest observer key inputs hencoding (fun cell => table cell.val) selections
+        (table ∘ encodingInputCell key.parameter inputs hencoding) dummy adversary := by
+  have hjoin : joinEncodingTable key.parameter inputs hencoding (table ∘ encodingInputCell key.parameter inputs hencoding)
+      (fun cell => table cell.val) = table := UniformTableSplit.join_split _ _ table
+  have hs : referenceTableSelection key (finiteHashAnswer ∅ inputs (joinEncodingTable key.parameter inputs hencoding
+      (table ∘ encodingInputCell key.parameter inputs hencoding) (fun cell => table cell.val))) = selections := by
+    rw [hjoin]
+    exact hselected
+  have h := referenceEncodingRest_selected observer key inputs hencoding hgraph (fun cell => table cell.val) selections
+    (table ∘ encodingInputCell key.parameter inputs hencoding) hs dummy adversary
+  simpa only [hjoin] using h
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceEncodingLazySource.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceEncodingLazySource.lean
new file mode 100644
index 000000000..4c55b7d32
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceEncodingLazySource.lean
@@ -0,0 +1,65 @@
+import SphincsSecurity.Proof.Ots.EncodingOracleObservation
+import SphincsSecurity.Proof.Ots.ReferenceEncodingPriorSource
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec UniformTableCompletion
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs Finset.univ
+
+noncomputable def referenceEncodingLazyRest {Result : Type} (observer : FrontierObserver Result)
+    (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+    (outside : NonencodingRows key.parameter inputs hencoding) (selections : ReferenceFamily)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    SPMF (Result × (canonicalEncodingInputs key.parameter → Finset HashOutput)) :=
+  let words := referenceFamilyWords selections dummy
+  let frontier := canonicalGraphFrontier key.otsSecret (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret
+    (nonencodingAnswer key.parameter inputs hencoding outside)) words
+  EncodingObservation.lazyRun key.parameter inputs hencoding outside
+    (observer key.parameter words frontier (referenceEncodingProgram key inputs hencoding outside selections dummy adversary))
+    (referenceEncodingAllowed key.parameter (outsideGraphMessage key inputs hencoding outside) selections)
+
+theorem referenceEncodingLazyRest_original {Result : Type} (observer : FrontierObserver Result)
+    (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+    (outside : NonencodingRows key.parameter inputs hencoding) (selections : ReferenceFamily)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (complete (referenceEncodingAllowed key.parameter (outsideGraphMessage key inputs hencoding outside) selections) >>= fun encoding =>
+      𝒟[referenceEncodingRest observer key inputs hencoding outside selections encoding dummy adversary]) =
+        Prod.fst <$> referenceEncodingLazyRest observer key inputs hencoding outside selections dummy adversary := by
+  unfold referenceEncodingRest referenceEncodingLazyRest
+  exact EncodingObservation.lazyRun_original key.parameter inputs hencoding outside _ _
+    (referenceEncodingAllowed_nonempty key.parameter (outsideGraphMessage key inputs hencoding outside) selections)
+
+noncomputable def referenceEncodingLazyGame {Result : Type} (observer : FrontierObserver Result)
+    (inputs : Finset HashInput) (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) : SPMF (InstrumentedResult Result) := do
+  let parameter ← 𝒟[sampleParameter]
+  let otsSecret ← 𝒟[sampleOtsSecrets]
+  let ftsSecret ← 𝒟[sampleFtsSecrets]
+  let key : SecretKey := ⟨parameter, 0, otsSecret, ftsSecret⟩
+  let selections ← 𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit]
+  let outside ← 𝒟[PMF.uniformOfFintype (NonencodingRows parameter inputs (hencoding parameter))]
+  let result ← Prod.fst <$> referenceEncodingLazyRest observer key inputs (hencoding parameter) outside selections dummy adversary
+  pure (parameter, selections, result)
+
+theorem referenceEncodingLazyGame_original {Result : Type} (observer : FrontierObserver Result)
+    (inputs : Finset HashInput) (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    referenceEncodingLazyGame observer inputs hencoding dummy adversary =
+      referenceInstrumentedGame observer inputs hencoding dummy adversary := by
+  rw [← referenceEncodingTableGame_original observer inputs hencoding hgraph dummy adversary]
+  unfold referenceEncodingLazyGame referenceEncodingTableGame
+  apply congrArg (𝒟[sampleParameter] >>= ·)
+  funext parameter
+  apply congrArg (𝒟[sampleOtsSecrets] >>= ·)
+  funext otsSecret
+  apply congrArg (𝒟[sampleFtsSecrets] >>= ·)
+  funext ftsSecret
+  apply congrArg (𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit] >>= ·)
+  funext selections
+  apply congrArg (𝒟[PMF.uniformOfFintype (NonencodingRows parameter inputs (hencoding parameter))] >>= ·)
+  funext outside
+  rw [← bind_assoc, referenceEncodingLazyRest_original observer ⟨parameter, 0, otsSecret, ftsSecret⟩
+    inputs (hencoding parameter) outside selections dummy adversary]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceEncodingPriorSource.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceEncodingPriorSource.lean
new file mode 100644
index 000000000..19484e336
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceEncodingPriorSource.lean
@@ -0,0 +1,45 @@
+import SphincsSecurity.Proof.Ots.EncodingTablePrior
+import SphincsSecurity.Proof.Ots.ReferenceEncodingSource
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec UniformTableCompletion
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs Finset.univ
+
+noncomputable def referenceEncodingTableGame {Result : Type} (observer : FrontierObserver Result)
+    (inputs : Finset HashInput) (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) : SPMF (InstrumentedResult Result) := do
+  let parameter ← 𝒟[sampleParameter]
+  let otsSecret ← 𝒟[sampleOtsSecrets]
+  let ftsSecret ← 𝒟[sampleFtsSecrets]
+  let key : SecretKey := ⟨parameter, 0, otsSecret, ftsSecret⟩
+  let selections ← 𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit]
+  let outside ← 𝒟[PMF.uniformOfFintype (NonencodingRows parameter inputs (hencoding parameter))]
+  let encoding ← complete (referenceEncodingAllowed parameter (outsideGraphMessage key inputs (hencoding parameter) outside) selections)
+  let result ← 𝒟[referenceEncodingRest observer key inputs (hencoding parameter) outside selections encoding dummy adversary]
+  pure (parameter, selections, result)
+
+theorem referenceEncodingTableGame_original {Result : Type} (observer : FrontierObserver Result)
+    (inputs : Finset HashInput) (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    referenceEncodingTableGame observer inputs hencoding dummy adversary =
+      referenceInstrumentedGame observer inputs hencoding dummy adversary := by
+  rw [← referenceEncodingGame_original observer inputs hencoding hgraph dummy adversary,
+    referenceEncodingGame_conditioned]
+  unfold referenceEncodingTableGame
+  apply congrArg (𝒟[sampleParameter] >>= ·)
+  funext parameter
+  apply congrArg (𝒟[sampleOtsSecrets] >>= ·)
+  funext otsSecret
+  apply congrArg (𝒟[sampleFtsSecrets] >>= ·)
+  funext ftsSecret
+  apply congrArg (𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit] >>= ·)
+  funext selections
+  apply congrArg (𝒟[PMF.uniformOfFintype (NonencodingRows parameter inputs (hencoding parameter))] >>= ·)
+  funext outside
+  rw [← referenceEncodingPrior_complete]
+  simp only [referenceEncodingPrior, ← PMF.monad_bind_eq_bind, ← PMF.monad_map_eq_map,
+    evalDist_bind, evalDist_map, bind_assoc, bind_map_left]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceEncodingProgram.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceEncodingProgram.lean
new file mode 100644
index 000000000..07205b3cf
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceEncodingProgram.lean
@@ -0,0 +1,105 @@
+import SphincsSecurity.Proof.Hypertree.FrontierEncodingCongruence
+import SphincsSecurity.Proof.Reference.CausalFrontierProgram
+import SphincsSecurity.Proof.Ots.ReferenceFamilyGame
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs frontierSigningRun frontierRoot
+
+theorem joinEncodingTable_agrees_outside (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+    (left right : canonicalEncodingInputs parameter → HashOutput)
+    (outside : NonencodingRows parameter inputs hencoding) :
+    AgreeOutsideEncoding parameter
+      (finiteHashAnswer ∅ inputs (joinEncodingTable parameter inputs hencoding left outside))
+      (finiteHashAnswer ∅ inputs (joinEncodingTable parameter inputs hencoding right outside)) := by
+  intro input hnot
+  by_cases hin : input ∈ inputs
+  · rw [finiteHashAnswer_none ∅ inputs _ _ hin (by simp), finiteHashAnswer_none ∅ inputs _ _ hin (by simp)]
+    let cell : UniformTableSplit.Outside (encodingInputCell parameter inputs hencoding) :=
+      ⟨⟨input, hin⟩, UniformTableSplit.inclusion_not_range hencoding ⟨input, hin⟩ hnot⟩
+    exact (UniformTableSplit.join_outside _ _ left outside cell).trans
+      (UniformTableSplit.join_outside _ _ right outside cell).symm
+  · simp only [finiteHashAnswer, QueryCache.empty_apply, Option.getD_none, dif_neg hin]
+
+theorem frontierLayerSearch_eq_referenceSelection (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (hfrontier : IsSigningFrontier key f words frontier) (selections : ReferenceFamily)
+    (hselected : referenceTableSelection key f = selections) (index : Index) (lay : Layer) :
+    frontierLayerSearch key.parameter f key.ftsSecret words frontier index lay =
+      referenceSelectionResult (selections ⟨lay, treeIndexAt index lay, leafIndexAt index lay⟩) := by
+  rw [frontierLayerSearch, eval_frontierLayerMessage key f words frontier hfrontier,
+    ← canonicalEncodingSearch_at,
+    ← referenceSelectionResult_eq_search key f ⟨lay, treeIndexAt index lay, leafIndexAt index lay⟩, hselected]
+
+namespace CausalFrontierProgram
+
+theorem game_eq_of_encoding (parameter : PublicParameter) (f g : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords)
+    (frontier : OtsFrontierValues) (adversary : Adversary) (h : AgreeOutsideEncoding parameter f g)
+    (hsearch : ∀ index lay, frontierLayerSearch parameter f ftsSecret words frontier index lay =
+      frontierLayerSearch parameter g ftsSecret words frontier index lay) :
+    game parameter f ftsSecret words frontier adversary = game parameter g ftsSecret words frontier adversary := by
+  have hsign (root : Digest) (message : Message) :
+      frontierSigningRun parameter root (maskOtsPrefixes parameter words f) ftsSecret words frontier message =
+        frontierSigningRun parameter root (maskOtsPrefixes parameter words g) ftsSecret words frontier message := by
+    rw [← frontierSigningRun_eq_of_agree parameter words f _ (maskOtsPrefixes_agrees parameter words f),
+      ← frontierSigningRun_eq_of_agree parameter words g _ (maskOtsPrefixes_agrees parameter words g)]
+    exact h.frontierSigningRun root ftsSecret words frontier hsearch message
+  have himpl (root : Digest) : adversaryImpl parameter root f ftsSecret words frontier =
+      adversaryImpl parameter root g ftsSecret words frontier := by
+    funext input
+    cases input with
+    | inl input => rfl
+    | inr message => simp only [adversaryImpl_signing, hsign]
+  rw [game, game,
+    ← frontierRoot_eq_of_agree parameter words f _ (maskOtsPrefixes_agrees parameter words f),
+    ← frontierRoot_eq_of_agree parameter words g _ (maskOtsPrefixes_agrees parameter words g),
+    h.frontierRoot words frontier]
+  simp only [gameRest, adversaryRun, himpl]
+
+end CausalFrontierProgram
+
+theorem joinedEncoding_isSigningFrontier (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (hgraph : canonicalGraphInputs key.parameter ⊆ inputs)
+    (encoding : canonicalEncodingInputs key.parameter → HashOutput)
+    (outside : NonencodingRows key.parameter inputs hencoding) (words : OtsReferenceWords) :
+    IsSigningFrontier key (finiteHashAnswer ∅ inputs (joinEncodingTable key.parameter inputs hencoding encoding outside))
+      words (canonicalGraphFrontier key.otsSecret (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret
+        (nonencodingAnswer key.parameter inputs hencoding outside)) words) := by
+  have hfrontier := canonicalGraphLabels_frontier key.parameter key.otsSecret key.ftsSecret
+    (finiteHashAnswer ∅ inputs (joinEncodingTable key.parameter inputs hencoding encoding outside)) words key.root
+  rw [canonicalGraphLabels_joinEncodingTable _ _ _ _ hencoding hgraph] at hfrontier
+  rw [hfrontier]
+  exact isSigningFrontier_canonical key _ words
+
+theorem joinedEncoding_program_eq (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (hgraph : canonicalGraphInputs key.parameter ⊆ inputs)
+    (left right : canonicalEncodingInputs key.parameter → HashOutput)
+    (outside : NonencodingRows key.parameter inputs hencoding) (selections : ReferenceFamily)
+    (hleft : referenceTableSelection key
+      (finiteHashAnswer ∅ inputs (joinEncodingTable key.parameter inputs hencoding left outside)) = selections)
+    (hright : referenceTableSelection key
+      (finiteHashAnswer ∅ inputs (joinEncodingTable key.parameter inputs hencoding right outside)) = selections)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    let words := referenceFamilyWords selections dummy
+    let frontier := canonicalGraphFrontier key.otsSecret (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret
+      (nonencodingAnswer key.parameter inputs hencoding outside)) words
+    CausalFrontierProgram.game key.parameter
+        (finiteHashAnswer ∅ inputs (joinEncodingTable key.parameter inputs hencoding left outside))
+        key.ftsSecret words frontier adversary =
+      CausalFrontierProgram.game key.parameter
+        (finiteHashAnswer ∅ inputs (joinEncodingTable key.parameter inputs hencoding right outside))
+        key.ftsSecret words frontier adversary := by
+  dsimp only
+  apply CausalFrontierProgram.game_eq_of_encoding
+  · exact joinEncodingTable_agrees_outside _ _ _ _ _ _
+  · intro index lay
+    rw [frontierLayerSearch_eq_referenceSelection key _ _ _
+      (joinedEncoding_isSigningFrontier key inputs hencoding hgraph left outside _) selections hleft,
+      frontierLayerSearch_eq_referenceSelection key _ _ _
+      (joinedEncoding_isSigningFrontier key inputs hencoding hgraph right outside _) selections hright]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceEncodingSource.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceEncodingSource.lean
new file mode 100644
index 000000000..0ce5c8a58
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceEncodingSource.lean
@@ -0,0 +1,118 @@
+import SphincsSecurity.Proof.Ots.ReferenceEncodingErasure
+import SphincsSecurity.Proof.Ots.EncodingConditionalObservation
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs Finset.univ referenceEncodingRest
+
+noncomputable def referenceEncodingGame {Result : Type} (observer : FrontierObserver Result)
+    (inputs : Finset HashInput) (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) : SPMF (InstrumentedResult Result) := do
+  let parameter ← 𝒟[sampleParameter]
+  let otsSecret ← 𝒟[sampleOtsSecrets]
+  let ftsSecret ← 𝒟[sampleFtsSecrets]
+  let key : SecretKey := ⟨parameter, 0, otsSecret, ftsSecret⟩
+  let reference ← 𝒟[referenceFamilyOracleSample key inputs (hencoding parameter)]
+  let result ← 𝒟[referenceEncodingRest observer key inputs (hencoding parameter)
+    (fun cell => reference.2 cell.val) reference.1
+    (reference.2 ∘ encodingInputCell parameter inputs (hencoding parameter)) dummy adversary]
+  pure (parameter, reference.1, result)
+
+theorem referenceEncodingGame_original {Result : Type} (observer : FrontierObserver Result)
+    (inputs : Finset HashInput) (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    referenceEncodingGame observer inputs hencoding dummy adversary =
+      referenceInstrumentedGame observer inputs hencoding dummy adversary := by
+  unfold referenceEncodingGame referenceInstrumentedGame
+  apply congrArg (𝒟[sampleParameter] >>= ·)
+  funext parameter
+  apply congrArg (𝒟[sampleOtsSecrets] >>= ·)
+  funext otsSecret
+  apply congrArg (𝒟[sampleFtsSecrets] >>= ·)
+  funext ftsSecret
+  apply evalDist_bind_congr (m := SPMF)
+  intro reference hreference
+  have hselected := referenceFamilyOracleSample_selections ⟨parameter, 0, otsSecret, ftsSecret⟩ inputs
+    (hencoding parameter) (hgraph parameter) reference
+    (by simpa only [PMF.evalDist_eq, SPMF.support_eq_support, SPMF.support_liftM] using hreference)
+  dsimp only
+  rw [referenceEncodingRest_table observer ⟨parameter, 0, otsSecret, ftsSecret⟩ inputs
+    (hencoding parameter) (hgraph parameter) reference.1 reference.2 hselected.symm dummy adversary]
+
+private theorem join_comp {Index Cell Answer : Type} (embed : Index → Cell) (hinj : Function.Injective embed)
+    (rows : Index → Answer) (outside : UniformTableSplit.Outside embed → Answer) :
+    UniformTableSplit.join embed hinj rows outside ∘ embed = rows :=
+  funext fun index => UniformTableSplit.join_embed embed hinj rows outside index
+
+private theorem join_outside {Index Cell Answer : Type} (embed : Index → Cell) (hinj : Function.Injective embed)
+    (rows : Index → Answer) (outside : UniformTableSplit.Outside embed → Answer) :
+    (fun cell : UniformTableSplit.Outside embed => UniformTableSplit.join embed hinj rows outside cell.val) = outside :=
+  funext fun cell => UniformTableSplit.join_outside embed hinj rows outside cell
+
+theorem referenceEncodingRest_join {Result : Type} (observer : FrontierObserver Result)
+    (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+    (outside : NonencodingRows key.parameter inputs hencoding) (selections : ReferenceFamily)
+    (encoding : canonicalEncodingInputs key.parameter → HashOutput)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    let table := joinEncodingTable key.parameter inputs hencoding encoding outside
+    referenceEncodingRest observer key inputs hencoding (fun cell => table cell.val) selections
+        (table ∘ encodingInputCell key.parameter inputs hencoding) dummy adversary =
+      referenceEncodingRest observer key inputs hencoding outside selections encoding dummy adversary := by
+  have hout : (fun cell : UniformTableSplit.Outside (encodingInputCell key.parameter inputs hencoding) =>
+      joinEncodingTable key.parameter inputs hencoding encoding outside cell.val) = outside :=
+    join_outside (encodingInputCell key.parameter inputs hencoding)
+      (encodingInputCell_injective key.parameter inputs hencoding) encoding outside
+  have hin : joinEncodingTable key.parameter inputs hencoding encoding outside ∘
+      encodingInputCell key.parameter inputs hencoding = encoding :=
+    join_comp (encodingInputCell key.parameter inputs hencoding)
+      (encodingInputCell_injective key.parameter inputs hencoding) encoding outside
+  exact congrArg₂ (fun outside encoding =>
+    referenceEncodingRest observer key inputs hencoding outside selections encoding dummy adversary) hout hin
+
+theorem referenceEncodingGame_conditioned {Result : Type} (observer : FrontierObserver Result)
+    (inputs : Finset HashInput) (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    referenceEncodingGame observer inputs hencoding dummy adversary = (do
+      let parameter ← 𝒟[sampleParameter]
+      let otsSecret ← 𝒟[sampleOtsSecrets]
+      let ftsSecret ← 𝒟[sampleFtsSecrets]
+      let key : SecretKey := ⟨parameter, 0, otsSecret, ftsSecret⟩
+      let selections ← 𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit]
+      let outside ← 𝒟[PMF.uniformOfFintype (NonencodingRows parameter inputs (hencoding parameter))]
+      let rows ← 𝒟[FirstSuccessFamily.afterSelect decodeEncodingOutput encodingAttemptLimit
+        decodeEncodingOutput_invalid_nonempty selections]
+      let remaining ← 𝒟[PMF.uniformOfFintype (UniformTableSplit.Outside
+        (referenceFamilyCell parameter (outsideGraphMessage key inputs (hencoding parameter) outside)) → HashOutput)]
+      let encoding := UniformTableSplit.join
+        (referenceFamilyCell parameter (outsideGraphMessage key inputs (hencoding parameter) outside))
+        (referenceFamilyCell_injective parameter (outsideGraphMessage key inputs (hencoding parameter) outside))
+        (Function.uncurry rows) remaining
+      let result ← 𝒟[referenceEncodingRest observer key inputs (hencoding parameter) outside selections encoding dummy adversary]
+      pure (parameter, selections, result)) := by
+  simp only [referenceEncodingGame, referenceFamilyOracleSample, ← PMF.monad_bind_eq_bind,
+    ← PMF.monad_map_eq_map, evalDist_bind, evalDist_map, bind_assoc, bind_map_left,
+    referenceFamilyOracleTable]
+  apply congrArg (𝒟[sampleParameter] >>= ·)
+  funext parameter
+  apply congrArg (𝒟[sampleOtsSecrets] >>= ·)
+  funext otsSecret
+  apply congrArg (𝒟[sampleFtsSecrets] >>= ·)
+  funext ftsSecret
+  apply congrArg (𝒟[FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit] >>= ·)
+  funext selections
+  apply congrArg (𝒟[PMF.uniformOfFintype (NonencodingRows parameter inputs (hencoding parameter))] >>= ·)
+  funext outside
+  apply congrArg (𝒟[FirstSuccessFamily.afterSelect decodeEncodingOutput encodingAttemptLimit
+    decodeEncodingOutput_invalid_nonempty selections] >>= ·)
+  funext rows
+  apply congrArg (𝒟[PMF.uniformOfFintype (UniformTableSplit.Outside
+    (referenceFamilyCell parameter (outsideGraphMessage ⟨parameter, 0, otsSecret, ftsSecret⟩ inputs
+      (hencoding parameter) outside)) → HashOutput)] >>= ·)
+  funext remaining
+  rw [referenceEncodingRest_join observer ⟨parameter, 0, otsSecret, ftsSecret⟩ inputs
+    (hencoding parameter) outside selections _ dummy adversary]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceEncodingTable.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceEncodingTable.lean
new file mode 100644
index 000000000..e7969b7bf
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceEncodingTable.lean
@@ -0,0 +1,65 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Ots.EncodingSelectionCache
+import SphincsSecurity.Proof.Base.FirstSuccessTable
+import SphincsSecurity.Proof.Hypertree.FrontierSigningEvaluation
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+def decodeEncodingOutput (output : HashOutput) : Option Encoding := TargetSum.decodeDigest (truncateHash output)
+
+theorem decodeEncodingOutput_invalid_nonempty : (FirstSuccessTable.invalid decodeEncodingOutput).Nonempty := by
+  refine ⟨0, (FirstSuccessTable.mem_invalid _ _).mpr ?_⟩
+  decide
+
+def referenceEncodingTable (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (position : EncodingPosition) (message : Digest) (attempts start : Nat) : Fin attempts → HashOutput :=
+  fun index => f (encodingRetryInput parameter position message (start + index.val))
+
+def encodingTableResult {n : Nat} (table : Fin n → HashOutput) (start : Nat) : Option (Counter × Encoding) × Nat :=
+  let result := FirstSuccessTable.select decodeEncodingOutput table
+  (result.map (fun result => (BitVec.ofNat counterBits (start + result.1.val), result.2)),
+    result.elim n (fun result => result.1.val + 1))
+
+theorem eval_encode_eq_decodeEncodingOutput (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (position : EncodingPosition) (message : Digest) (counter : Nat) :
+    evalWithAnswerFn f (encode parameter position.lay position.tree position.leafIdx message
+      (BitVec.ofNat counterBits counter)) =
+        decodeEncodingOutput (f (encodingRetryInput parameter position message counter)) := by
+  simp only [encode, evalWithAnswerFn_bind, eval_tweakableHash, evalWithAnswerFn_pure]
+  rfl
+
+theorem referenceEncodingSearch_eq_table (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (position : EncodingPosition) (message : Digest) (attempts start : Nat) :
+    referenceEncodingSearch parameter f position.lay position.tree position.leafIdx message attempts start =
+      encodingTableResult (referenceEncodingTable parameter f position message attempts start) start := by
+  induction attempts generalizing start with
+  | zero => rfl
+  | succ attempts ih =>
+      have htail :
+          (fun i : Fin attempts => referenceEncodingTable parameter f position message (attempts + 1) start i.succ) =
+            referenceEncodingTable parameter f position message attempts (start + 1) := by
+        funext i
+        change f (encodingRetryInput parameter position message (start + (i.val + 1))) =
+          f (encodingRetryInput parameter position message (start + 1 + i.val))
+        rw [show start + (i.val + 1) = start + 1 + i.val by omega]
+      rw [referenceEncodingSearch, eval_encode_eq_decodeEncodingOutput,
+        encodingTableResult, FirstSuccessTable.select]
+      have hzero : referenceEncodingTable parameter f position message (attempts + 1) start 0 =
+          f (encodingRetryInput parameter position message start) := by simp [referenceEncodingTable]
+      rw [hzero]
+      cases hdecode : decodeEncodingOutput (f (encodingRetryInput parameter position message start)) with
+      | some word => simp
+      | none =>
+          rw [htail, ih]
+          unfold encodingTableResult
+          cases hselected : FirstSuccessTable.select decodeEncodingOutput
+              (referenceEncodingTable parameter f position message attempts (start + 1)) with
+          | none => simp [Nat.add_comm]
+          | some result =>
+              rcases result with ⟨index, word⟩
+              simp [Nat.add_comm, Nat.add_left_comm]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceFamilyAllocation.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceFamilyAllocation.lean
new file mode 100644
index 000000000..27921875a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceFamilyAllocation.lean
@@ -0,0 +1,65 @@
+import SphincsSecurity.Proof.Ots.OtsPrefixAllocation
+import SphincsSecurity.Proof.Ots.ReferenceFamilyGame
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalGraphInputs canonicalEncodingInputs canonicalGraphGameInputs
+
+noncomputable def referenceRecordedRest (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (labels : CanonicalGraphLabels) (selections : ReferenceFamily) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    ProbComp ((Bool × SigningBoundaryTrace) × List OracleWorld.Domain) :=
+  let words := referenceFamilyWords selections dummy
+  simulateQ (fixedHashWorld f) (QueryCap.recorded (CausalFrontierProgram.game key.parameter f key.ftsSecret words
+    (canonicalGraphFrontier key.otsSecret labels words) adversary))
+
+theorem referenceRecordedRest_erased (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (labels : CanonicalGraphLabels) (selections : ReferenceFamily) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    Prod.fst <$> referenceRecordedRest key f labels selections dummy adversary =
+      referenceFamilyFrontierRest key f labels selections dummy adversary := by
+  rw [referenceRecordedRest, ← simulateQ_map, QueryCap.recorded_forget, CausalFrontierProgram.fixed_game,
+    referenceFamilyFrontierRest, causalFrontierGame_eq]
+
+abbrev ReferenceRecordedResult := PublicParameter × ReferenceFamily × ((Bool × SigningBoundaryTrace) × List OracleWorld.Domain)
+
+def ReferenceRecordedResult.erase (result : ReferenceRecordedResult) : ReferenceFamily × (Bool × SigningBoundaryTrace) :=
+  (result.2.1, result.2.2.1)
+
+noncomputable def referenceRecordedGame (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) : SPMF ReferenceRecordedResult := do
+  let parameter ← 𝒟[sampleParameter]
+  let otsSecret ← 𝒟[sampleOtsSecrets]
+  let ftsSecret ← 𝒟[sampleFtsSecrets]
+  let key : SecretKey := ⟨parameter, 0, otsSecret, ftsSecret⟩
+  let reference ← 𝒟[referenceFamilyOracleSample key inputs (hencoding parameter)]
+  let f := finiteHashAnswer ∅ inputs reference.2
+  let result ← 𝒟[referenceRecordedRest key f
+    (canonicalGraphLabels parameter otsSecret ftsSecret f) reference.1 dummy adversary]
+  pure (parameter, reference.1, result)
+
+theorem referenceRecordedGame_erased (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    ReferenceRecordedResult.erase <$> referenceRecordedGame inputs hencoding dummy adversary =
+      referenceFamilyGame inputs hencoding dummy adversary := by
+  unfold referenceRecordedGame referenceFamilyGame
+  simp only [map_bind, map_pure, ReferenceRecordedResult.erase]
+  apply congrArg (𝒟[sampleParameter] >>= ·)
+  funext parameter
+  apply congrArg (𝒟[sampleOtsSecrets] >>= ·)
+  funext otsSecret
+  apply congrArg (𝒟[sampleFtsSecrets] >>= ·)
+  funext ftsSecret
+  apply congrArg (𝒟[referenceFamilyOracleSample _ inputs (hencoding parameter)] >>= ·)
+  funext reference
+  rw [← referenceRecordedRest_erased, evalDist_map, bind_map_left]
+
+theorem referenceRecordedGame_hashCalls_le (dummy : OtsReferenceWords) (adversary : Adversary) (q : Nat)
+    (hbound : HasHashQueryBound scheme adversary q) (result : ReferenceRecordedResult)
+    (hresult : result ∈ support (referenceRecordedGame (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary)) : result.2.2.1.2.hashCalls ≤ q := by
+  apply referenceFamilyGame_hashCalls_le dummy adversary q hbound result.erase
+  rw [← referenceRecordedGame_erased, support_map]
+  exact ⟨result, hresult, rfl⟩
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceFamilyConditioning.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceFamilyConditioning.lean
new file mode 100644
index 000000000..b751a2e15
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceFamilyConditioning.lean
@@ -0,0 +1,77 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Ots.EncodingFamilyOracleSplit
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs
+set_option backward.isDefEq.respectTransparency false
+
+theorem uniform_bind_referenceFamily {Result : Type} (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (hgraph : canonicalGraphInputs key.parameter ⊆ inputs)
+    (next : ReferenceFamily → (inputs → HashOutput) → PMF Result) :
+    (PMF.uniformOfFintype (inputs → HashOutput)).bind
+        (fun table => next (referenceTableSelection key (finiteHashAnswer ∅ inputs table)) table) =
+      (PMF.uniformOfFintype (NonencodingRows key.parameter inputs hencoding)).bind (fun outside =>
+        (FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit).bind (fun results =>
+          (FirstSuccessFamily.afterSelect decodeEncodingOutput encodingAttemptLimit decodeEncodingOutput_invalid_nonempty results).bind
+            (fun rows => (PMF.uniformOfFintype (UniformTableSplit.Outside
+              (referenceFamilyCell key.parameter (outsideGraphMessage key inputs hencoding outside)) → HashOutput)).bind
+                (fun remaining => next results (referenceFamilyOracleTable key inputs hencoding outside rows remaining))))) := by
+  rw [UniformTableSplit.uniform_bind_split (encodingInputCell key.parameter inputs hencoding)
+    (encodingInputCell_injective key.parameter inputs hencoding), PMF.bind_comm]
+  apply congrArg (PMF.uniformOfFintype (NonencodingRows key.parameter inputs hencoding)).bind
+  funext outside
+  change ((PMF.uniformOfFintype (canonicalEncodingInputs key.parameter → HashOutput)).bind
+    (fun encoding => next (fun position => referenceTableSelection key
+      (finiteHashAnswer ∅ inputs (joinEncodingTable key.parameter inputs hencoding encoding outside)) position)
+      (joinEncodingTable key.parameter inputs hencoding encoding outside))) = _
+  simp only [referenceTableSelection_joinEncodingTable key inputs hencoding hgraph]
+  exact UniformTableSplit.uniform_bind_firstSuccessFamily
+    (referenceFamilyCell key.parameter (outsideGraphMessage key inputs hencoding outside))
+    (referenceFamilyCell_injective key.parameter (outsideGraphMessage key inputs hencoding outside))
+    decodeEncodingOutput decodeEncodingOutput_invalid_nonempty
+    (fun results encoding => next results (joinEncodingTable key.parameter inputs hencoding encoding outside))
+
+noncomputable def referenceFamilyOracleSample (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) : PMF (ReferenceFamily × (inputs → HashOutput)) :=
+  (FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit).bind (fun results =>
+    (PMF.uniformOfFintype (NonencodingRows key.parameter inputs hencoding)).bind (fun outside =>
+      (FirstSuccessFamily.afterSelect decodeEncodingOutput encodingAttemptLimit decodeEncodingOutput_invalid_nonempty results).bind
+        (fun rows => (PMF.uniformOfFintype (UniformTableSplit.Outside
+          (referenceFamilyCell key.parameter (outsideGraphMessage key inputs hencoding outside)) → HashOutput)).map
+            (fun remaining => (results, referenceFamilyOracleTable key inputs hencoding outside rows remaining)))))
+
+theorem uniform_joint_eq_referenceFamilyOracleSample (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (hgraph : canonicalGraphInputs key.parameter ⊆ inputs) :
+    (PMF.uniformOfFintype (inputs → HashOutput)).map
+        (fun table => (referenceTableSelection key (finiteHashAnswer ∅ inputs table), table)) =
+      referenceFamilyOracleSample key inputs hencoding := by
+  have h := uniform_bind_referenceFamily key inputs hencoding hgraph (fun results table => PMF.pure (results, table))
+  rw [PMF.bind_comm] at h
+  exact h
+
+theorem referenceFamilyOracleSample_selections (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (hgraph : canonicalGraphInputs key.parameter ⊆ inputs)
+    (result : ReferenceFamily × (inputs → HashOutput))
+    (hresult : result ∈ (referenceFamilyOracleSample key inputs hencoding).support) :
+    result.1 = referenceTableSelection key (finiteHashAnswer ∅ inputs result.2) := by
+  rw [← uniform_joint_eq_referenceFamilyOracleSample key inputs hencoding hgraph, PMF.mem_support_map_iff] at hresult
+  obtain ⟨table, _, rfl⟩ := hresult
+  rfl
+
+noncomputable local instance instSampleableTypeForallSubtypeHashInputMemFinsetHashOutput_4 (inputs : Finset HashInput) : SampleableType (inputs → HashOutput) :=
+  SampleableType.ofFintype (inputs → HashOutput)
+
+theorem referenceFamilyOracleSample_bind_selected {Result : Type} (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (hgraph : canonicalGraphInputs key.parameter ⊆ inputs)
+    (next : ReferenceFamily → (inputs → HashOutput) → ProbComp Result) :
+    (𝒟[referenceFamilyOracleSample key inputs hencoding] >>= fun result => 𝒟[next result.1 result.2]) =
+      𝒟[do
+        let table ← sampleHashTable inputs
+        next (referenceTableSelection key (finiteHashAnswer ∅ inputs table)) table] := by
+  rw [← uniform_joint_eq_referenceFamilyOracleSample key inputs hencoding hgraph]
+  simp only [← PMF.monad_map_eq_map, map_eq_bind_pure_comp, bind_assoc, pure_bind,
+    evalDist_bind, evalDist_pure, Function.comp_apply, sampleHashTable, evalDist_uniformSample]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceFamilyGame.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceFamilyGame.lean
new file mode 100644
index 000000000..39bbd3eff
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceFamilyGame.lean
@@ -0,0 +1,139 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.CanonicalGraphGame
+import SphincsSecurity.Proof.Reference.CausalFrontierGame
+import SphincsSecurity.Proof.Ots.ReferenceFamilyConditioning
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec OracleComp.DeferredSampling
+attribute [local irreducible] canonicalGraphInputs canonicalEncodingInputs canonicalGraphGameInputs
+set_option backward.isDefEq.respectTransparency false
+
+def fixedReferenceDummyWord : Encoding :=
+  fun index => if index.val < 27 then ⟨7, by decide⟩ else if index.val = 27 then ⟨2, by decide⟩ else ⟨0, by decide⟩
+
+theorem fixedReferenceDummyWord_valid : TargetSum.Valid fixedReferenceDummyWord := by
+  change (∑ index : Fin 42, if index.val < 27 then (7 : Nat) else if index.val = 27 then 2 else 0) = 191
+  norm_num [Fin.sum_univ_succ]
+
+def fixedReferenceDummy : OtsReferenceWords := fun _ _ _ => fixedReferenceDummyWord
+
+def referenceFamilyWords (selections : ReferenceFamily) (dummy : OtsReferenceWords) : OtsReferenceWords :=
+  fun lay tree leaf => ((selections ⟨lay, tree, leaf⟩).map Prod.snd).getD (dummy lay tree leaf)
+
+theorem referenceFamilyWords_selected (key : SecretKey) (f : QueryImpl HashSpec Id) (dummy : OtsReferenceWords) :
+    referenceFamilyWords (referenceTableSelection key f) dummy = canonicalReferenceWords key f dummy := by
+  funext lay tree leaf
+  rw [referenceFamilyWords, canonicalReferenceWords,
+    ← referenceSelectionResult_eq_search key f ⟨lay, tree, leaf⟩]
+  simp only [referenceSelectionResult, Option.map_map, Function.comp_def]
+
+theorem referenceFamilyOracleSample_words (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (hgraph : canonicalGraphInputs key.parameter ⊆ inputs)
+    (result : ReferenceFamily × (inputs → HashOutput))
+    (hresult : result ∈ (referenceFamilyOracleSample key inputs hencoding).support) (dummy : OtsReferenceWords) :
+    referenceFamilyWords result.1 dummy = canonicalReferenceWords key (finiteHashAnswer ∅ inputs result.2) dummy := by
+  rw [referenceFamilyOracleSample_selections key inputs hencoding hgraph result hresult, referenceFamilyWords_selected]
+
+theorem referenceFamilyOracleSample_words_valid (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (hgraph : canonicalGraphInputs key.parameter ⊆ inputs)
+    (result : ReferenceFamily × (inputs → HashOutput))
+    (hresult : result ∈ (referenceFamilyOracleSample key inputs hencoding).support) (dummy : OtsReferenceWords)
+    (hdummy : ∀ lay tree leaf, TargetSum.Valid (dummy lay tree leaf)) :
+    ∀ lay tree leaf, TargetSum.Valid (referenceFamilyWords result.1 dummy lay tree leaf) := by
+  rw [referenceFamilyOracleSample_words key inputs hencoding hgraph result hresult dummy]
+  exact canonicalReferenceWords_valid key (finiteHashAnswer ∅ inputs result.2) dummy hdummy
+
+noncomputable def referenceFamilyFrontierRest (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (labels : CanonicalGraphLabels) (selections : ReferenceFamily) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    ProbComp (Bool × SigningBoundaryTrace) :=
+  let words := referenceFamilyWords selections dummy
+  causalFrontierGame key.parameter f key.ftsSecret words (canonicalGraphFrontier key.otsSecret labels words) adversary
+
+theorem referenceFamilyFrontierRest_selected (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (labels : CanonicalGraphLabels) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    referenceFamilyFrontierRest key f labels (referenceTableSelection key f) dummy adversary =
+      graphFrontierGameRest key.parameter key.otsSecret key.ftsSecret labels f dummy adversary := by
+  rw [referenceFamilyFrontierRest, referenceFamilyWords_selected, causalFrontierGame_eq, graphFrontierGameRest]
+  rfl
+
+noncomputable def referenceFamilyGame (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) : SPMF (ReferenceFamily × (Bool × SigningBoundaryTrace)) := do
+  let parameter ← 𝒟[sampleParameter]
+  let otsSecret ← 𝒟[sampleOtsSecrets]
+  let ftsSecret ← 𝒟[sampleFtsSecrets]
+  let key : SecretKey := ⟨parameter, 0, otsSecret, ftsSecret⟩
+  let reference ← 𝒟[referenceFamilyOracleSample key inputs (hencoding parameter)]
+  let f := finiteHashAnswer ∅ inputs reference.2
+  let result ← 𝒟[referenceFamilyFrontierRest key f
+    (canonicalGraphLabels parameter otsSecret ftsSecret f) reference.1 dummy adversary]
+  pure (reference.1, result)
+
+theorem referenceFamilyGame_erased (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    Prod.snd <$> referenceFamilyGame inputs hencoding dummy adversary = 𝒟[frontierOracleGame inputs dummy adversary] := by
+  rw [referenceFamilyGame, frontierOracleGame]
+  simp_rw [← fixedGraphGame_eq_frontier]
+  simp only [fixedGraphGame, map_bind, map_pure, bind_pure]
+  rw [evalDist_bind_comm, evalDist_bind]
+  apply congrArg (𝒟[sampleParameter] >>= ·)
+  funext parameter
+  rw [evalDist_bind_comm, evalDist_bind]
+  apply congrArg (𝒟[sampleOtsSecrets] >>= ·)
+  funext otsSecret
+  rw [evalDist_bind_comm, evalDist_bind]
+  apply congrArg (𝒟[sampleFtsSecrets] >>= ·)
+  funext ftsSecret
+  rw [referenceFamilyOracleSample_bind_selected ⟨parameter, 0, otsSecret, ftsSecret⟩ inputs
+    (hencoding parameter) (hgraph parameter) (fun selections table =>
+      referenceFamilyFrontierRest ⟨parameter, 0, otsSecret, ftsSecret⟩ (finiteHashAnswer ∅ inputs table)
+        (canonicalGraphLabels parameter otsSecret ftsSecret (finiteHashAnswer ∅ inputs table)) selections dummy adversary)]
+  simp only [referenceFamilyFrontierRest_selected]
+
+theorem evalDist_boundaryGameCore_referenceFamily (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary)
+    (hinputs : hashInputs (boundaryGameCore adversary) ⊆ inputs) :
+    𝒟[(simulateQ romImpl (boundaryGameCore adversary)).run' ∅] =
+      Prod.snd <$> referenceFamilyGame inputs hencoding dummy adversary := by
+  exact (evalDist_boundaryGameCore_frontier inputs dummy adversary hinputs).trans
+    (referenceFamilyGame_erased inputs hencoding hgraph dummy adversary).symm
+
+theorem forgeAdvantage_eq_referenceFamily (dummy : OtsReferenceWords) (adversary : Adversary) :
+    forgeAdvantage scheme adversary =
+      Pr[fun result => result.2.1 = true |
+        referenceFamilyGame (canonicalGraphGameInputs adversary)
+          (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] := by
+  rw [forgeAdvantage, probOutput_def,
+    evalDist_gameCore_frontier (canonicalGraphGameInputs adversary) dummy adversary
+      (hashInputs_subset_canonicalGraphGameInputs adversary), evalDist_map,
+    ← referenceFamilyGame_erased (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary)
+      (canonicalGraphInputs_subset_gameInputs adversary) dummy adversary,
+    ← LawfulFunctor.comp_map]
+  change Pr[= true | (Prod.fst ∘ Prod.snd) <$>
+    referenceFamilyGame (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] = _
+  rw [probOutput_map]
+  rfl
+
+theorem referenceFamilyGame_hashCalls_le (dummy : OtsReferenceWords) (adversary : Adversary) (q : Nat)
+    (hbound : HasHashQueryBound scheme adversary q) (result : ReferenceFamily × (Bool × SigningBoundaryTrace))
+    (hresult : result ∈ support (referenceFamilyGame (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary)) :
+    result.2.2.hashCalls ≤ q := by
+  apply boundaryGameCore_hashCalls_le adversary q hbound result.2
+  apply (mem_support_iff_of_evalDist_eq
+    (mx' := Prod.snd <$> referenceFamilyGame (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary)
+    (evalDist_boundaryGameCore_referenceFamily (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary)
+      (canonicalGraphInputs_subset_gameInputs adversary) dummy adversary
+      (hashInputs_subset_canonicalGraphGameInputs adversary)) result.2).mpr
+  rw [support_map]
+  exact ⟨result, hresult, rfl⟩
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceFamilySeed.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceFamilySeed.lean
new file mode 100644
index 000000000..23fa6d3c9
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceFamilySeed.lean
@@ -0,0 +1,67 @@
+import SphincsSecurity.Proof.Ots.ReferenceFamilyConditioning
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs
+set_option backward.isDefEq.respectTransparency false
+
+namespace UniformTableSplit
+
+theorem uniform_outside {Index Cell Answer : Type} [Fintype Index] [Fintype Cell] [Fintype Answer]
+    [Nonempty Answer] [DecidableEq Index] [DecidableEq Cell]
+    (embed : Index → Cell) (hinj : Function.Injective embed) :
+    (PMF.uniformOfFintype (Cell → Answer)).map (fun table => fun cell : Outside embed => table cell.val) =
+      PMF.uniformOfFintype (Outside embed → Answer) := by
+  rw [uniform_join embed hinj, PMF.map_bind]
+  simp only [PMF.map_comp, Function.comp_def, join_outside, PMF.bind_const]
+  exact PMF.map_id _
+
+end UniformTableSplit
+
+structure ReferenceFamilySeed (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) where
+  selections : ReferenceFamily
+  nonencoding : NonencodingRows parameter inputs hencoding
+  selectedRows : EncodingPosition → Fin encodingAttemptLimit → HashOutput
+  encoding : canonicalEncodingInputs parameter → HashOutput
+
+noncomputable def referenceFamilySeedLawAt (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (selections : ReferenceFamily) :
+    PMF (ReferenceFamilySeed parameter inputs hencoding) :=
+  (PMF.uniformOfFintype (NonencodingRows parameter inputs hencoding)).bind (fun nonencoding =>
+    (FirstSuccessFamily.afterSelect decodeEncodingOutput encodingAttemptLimit decodeEncodingOutput_invalid_nonempty selections).bind
+      (fun selectedRows => (PMF.uniformOfFintype (canonicalEncodingInputs parameter → HashOutput)).map
+        (fun encoding => ⟨selections, nonencoding, selectedRows, encoding⟩)))
+
+noncomputable def referenceFamilySeedLaw (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) : PMF (ReferenceFamilySeed parameter inputs hencoding) :=
+  (FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit).bind
+    (referenceFamilySeedLawAt parameter inputs hencoding)
+
+noncomputable def referenceFamilySeedTable (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+    (seed : ReferenceFamilySeed key.parameter inputs hencoding) : inputs → HashOutput :=
+  referenceFamilyOracleTable key inputs hencoding seed.nonencoding seed.selectedRows
+    (fun cell => seed.encoding cell.val)
+
+theorem referenceFamilyOracleSample_eq_seed (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) :
+    referenceFamilyOracleSample key inputs hencoding =
+      (referenceFamilySeedLaw key.parameter inputs hencoding).map
+        (fun seed => (seed.selections, referenceFamilySeedTable key inputs hencoding seed)) := by
+  rw [referenceFamilyOracleSample, referenceFamilySeedLaw, PMF.map_bind]
+  apply congrArg (FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit).bind
+  funext selections
+  rw [referenceFamilySeedLawAt, PMF.map_bind]
+  apply congrArg (PMF.uniformOfFintype (NonencodingRows key.parameter inputs hencoding)).bind
+  funext nonencoding
+  rw [PMF.map_bind]
+  apply congrArg (FirstSuccessFamily.afterSelect decodeEncodingOutput encodingAttemptLimit
+    decodeEncodingOutput_invalid_nonempty selections).bind
+  funext selectedRows
+  rw [← UniformTableSplit.uniform_outside
+    (referenceFamilyCell key.parameter (outsideGraphMessage key inputs hencoding nonencoding))
+    (referenceFamilyCell_injective key.parameter (outsideGraphMessage key inputs hencoding nonencoding))]
+  simp only [PMF.map_comp, Function.comp_def, referenceFamilySeedTable]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceLayerWitness.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceLayerWitness.lean
new file mode 100644
index 000000000..d2fc77294
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferenceLayerWitness.lean
@@ -0,0 +1,69 @@
+import SphincsSecurity.Proof.Ots.LayerVerifierWitness
+import SphincsSecurity.Proof.Ots.PublicEncodingMatch
+namespace SphincsSecurity.Concrete.OtsVerifierWitness
+
+open _root_.OracleComp OracleSpec OtsContactTrace
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] chainWalk canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+variable (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (words : OtsReferenceWords)
+  (messages : EncodingPosition → Digest) (selections : ReferenceFamily)
+
+def EncodingOutputMatch (trace : Trace) : Prop :=
+  ∃ entry ∈ trace.toList, entry.1 ∈ canonicalEncodingInputs parameter ∧ PublicEncodingMatch.Match parameter messages words selections entry.1 entry.2
+
+theorem equal_word_reference (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex)
+    (message : Digest) (counter : Counter) (values : ChainIndex → Digest) (trace : Trace)
+    (hencode : evalWithAnswerFn f (encode parameter lay tree leaf message counter) = some (words lay tree leaf))
+    (hrun : ContainsRun f trace (otsLeaf parameter lay tree leaf message counter values)) :
+    (∃ selected, selections ⟨lay, tree, leaf⟩ = some selected ∧ message = messages ⟨lay, tree, leaf⟩ ∧
+      counter = BitVec.ofNat counterBits selected.1.val) ∨ EncodingOutputMatch parameter words messages selections trace := by
+  let position : EncodingPosition := ⟨lay, tree, leaf⟩
+  let input := tweakableHashInput parameter position.domain (digestBytes message ++ counterBytes counter)
+  by_cases hreference : PublicEncodingMatch.referenceInput parameter messages selections position = some input
+  · cases hselected : selections position with
+    | none => simp only [PublicEncodingMatch.referenceInput, hselected, Option.map_none, reduceCtorEq] at hreference
+    | some selected =>
+        have hinput : encodingRetryInput parameter position (messages position) selected.1.val = input := by
+          simpa only [PublicEncodingMatch.referenceInput, hselected, Option.map_some, Option.some.injEq] using hreference
+        have hpayload := (tweakableHashInput_injective parameter (by trivial) (by trivial) hinput).2
+        obtain ⟨hm, hc⟩ := List.append_inj hpayload (by simp [digestBytes_length])
+        exact Or.inl ⟨selected, rfl, (digestBytes_injective hm).symm, (bytesLE_injective hc).symm⟩
+  · refine Or.inr ⟨(input, f input), ?_, ?_, position, ⟨_, rfl⟩, hreference, ?_⟩
+    · apply hrun.bind_left
+      simp only [encode, queriedInputs_bind, queriedInputs_tweakableHash, queriedInputs_pure,
+        List.append_nil, List.mem_singleton, input, position, EncodingPosition.domain]
+    · have hcounter : counter.toNat < encodingAttemptLimit := by
+        simpa only [encodingAttemptLimit, counterBits] using counter.isLt
+      have hin := encodingRetryInput_mem_canonicalEncodingInputs parameter position message ⟨counter.toNat, hcounter⟩
+      simpa only [encodingRetryInput, BitVec.ofNat_toNat, BitVec.setWidth_eq, input] using hin
+    · exact decode_of_eval_encode_eq_some f parameter lay tree leaf message counter (words lay tree leaf) hencode
+
+theorem layer_reference_classification (lay : Layer) (tree : TreeIndex) (secret : LeafIndex → ChainIndex → Digest)
+    (leaf : LeafIndex) (hleafIndex : leaf.val < 2 ^ layerHeight lay) (path : Nat → Digest)
+    (message : Digest) (counter : Counter) (values : ChainIndex → Digest) (candidate : Encoding) (leafValue : Digest) (trace : Trace)
+    (hvalid : TargetSum.Valid (words lay tree leaf))
+    (hencode : evalWithAnswerFn f (encode parameter lay tree leaf message counter) = some candidate)
+    (hots : evalWithAnswerFn f (otsLeaf parameter lay tree leaf message counter values) = some leafValue)
+    (hfold : foldValue f parameter lay tree leaf path leafValue (layerHeight lay) = honestNode f parameter lay tree secret (layerHeight lay) 0)
+    (hotsRun : ContainsRun f trace (otsLeaf parameter lay tree leaf message counter values))
+    (hfoldRun : ContainsRun f trace (treeFold parameter lay tree leaf path (layerHeight lay) leafValue)) :
+    (∃ selected, selections ⟨lay, tree, leaf⟩ = some selected ∧ message = messages ⟨lay, tree, leaf⟩ ∧
+      counter = BitVec.ofNat counterBits selected.1.val ∧ candidate = words lay tree leaf ∧
+      (∀ index, values index = frontier f parameter words lay tree leaf (secret leaf) index) ∧
+      ∀ level, level < layerHeight lay → path level = honestNode f parameter lay tree secret level (Nat.xor (leaf.val / 2 ^ level) 1)) ∨
+      TreeOutputMatch f parameter lay tree secret trace ∨ LeafOutputMatch f parameter lay tree leaf (secret leaf) trace ∨
+        ChainException f parameter words lay tree leaf (secret leaf) trace ∨ EncodingOutputMatch parameter words messages selections trace := by
+  rcases layer_classification f parameter words lay tree secret leaf hleafIndex path message counter values candidate leafValue trace
+      hvalid hencode hots hfold hotsRun hfoldRun with ⟨hword, hvalues, hpath⟩ | ht | hl | hc
+  · rw [hword] at hencode
+    rcases equal_word_reference f parameter words messages selections lay tree leaf message counter values trace hencode hotsRun
+      with ⟨selected, hs, hm, hc⟩ | he
+    · exact Or.inl ⟨selected, hs, hm, hc, hword, hvalues, hpath⟩
+    · exact Or.inr (Or.inr (Or.inr (Or.inr he)))
+  · exact Or.inr (Or.inl ht)
+  · exact Or.inr (Or.inr (Or.inl hl))
+  · exact Or.inr (Or.inr (Or.inr (Or.inl hc)))
+
+end SphincsSecurity.Concrete.OtsVerifierWitness
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/ReferencePrefixGame.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferencePrefixGame.lean
new file mode 100644
index 000000000..fe0a23500
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferencePrefixGame.lean
@@ -0,0 +1,128 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Reference.ReferenceJointPrior
+import SphincsSecurity.Proof.Ots.ReferencePrefixResidual
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec UniformTableCompletion ResidualTableCompletion
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+theorem graphReferenceSample_eq_prefixAuxiliary (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) :
+    graphReferenceSample parameter inputs hencoding =
+      (referenceAuxiliarySample inputs).bind (fun auxiliary =>
+        (PMF.uniformOfFintype CanonicalGraphLabels).map (fun labels =>
+          (auxiliary.selections, (labels, canonicalPrefixResidual parameter inputs hencoding labels
+            auxiliary.selections auxiliary.rows auxiliary.seed)))) := by
+  rw [graphReferenceSample_eq_auxiliary]
+  simp only [referenceAuxiliarySample, PMF.bind_bind, PMF.map, Function.comp_def, PMF.pure_bind]
+  apply congrArg (FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit).bind
+  funext selections
+  conv_lhs => enter [2, rows]; rw [PMF.bind_comm]
+  rw [PMF.bind_comm]
+  conv_rhs => enter [2, rows]; rw [PMF.bind_comm]
+  conv_rhs => rw [PMF.bind_comm]
+  apply congrArg (PMF.uniformOfFintype CanonicalGraphLabels).bind
+  funext labels
+  have h := congrArg (PMF.map (fun residual => (selections, (labels, residual))))
+    (canonicalReferenceResidual_prefix_law parameter inputs hencoding labels selections)
+  simpa only [PMF.map, Function.comp_def, PMF.bind_bind, PMF.pure_bind] using h
+
+theorem referenceResidualGame_eq_prefixAuxiliary (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    referenceResidualGame inputs hencoding dummy adversary = (do
+      let parameter ← 𝒟[sampleParameter]
+      let otsSecret ← 𝒟[sampleOtsSecrets]
+      let ftsSecret ← 𝒟[sampleFtsSecrets]
+      let auxiliary ← 𝒟[referenceAuxiliarySample inputs]
+      let labels ← 𝒟[PMF.uniformOfFintype CanonicalGraphLabels]
+      let f := programmedHash parameter otsSecret ftsSecret labels
+        (finiteHashAnswer ∅ inputs (canonicalPrefixResidual parameter inputs (hencoding parameter) labels
+          auxiliary.selections auxiliary.rows auxiliary.seed))
+      let result ← 𝒟[referenceFamilyFrontierRest ⟨parameter, 0, otsSecret, ftsSecret⟩ f labels auxiliary.selections dummy adversary]
+      pure (auxiliary.selections, result)) := by
+  simp only [referenceResidualGame, graphReferenceSample_eq_prefixAuxiliary,
+    ← PMF.monad_bind_eq_bind, ← PMF.monad_map_eq_map, evalDist_bind, evalDist_map, bind_assoc, bind_map_left]
+
+noncomputable def referencePrefixCoordinateGame (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) : SPMF (ReferenceFamily × (Bool × SigningBoundaryTrace)) := do
+  let parameter ← 𝒟[sampleParameter]
+  let auxiliary ← 𝒟[referenceAuxiliarySample inputs]
+  let words := referenceFamilyWords auxiliary.selections dummy
+  let high ← 𝒟[PMF.uniformOfFintype CanonicalGraphHighHalves]
+  let exposedValues ← 𝒟[PMF.uniformOfFintype (InitialPublicLabels words)]
+  let labels ← complete (initialAllowed words exposedValues)
+  let ots := coordinateOtsSecrets labels
+  let fts := coordinateFtsSecrets labels
+  let graph := coordinateGraphLabels labels high
+  let f := programmedHash parameter ots fts graph
+    (finiteHashAnswer ∅ inputs (canonicalPrefixResidual parameter inputs (hencoding parameter) graph
+      auxiliary.selections auxiliary.rows auxiliary.seed))
+  let result ← 𝒟[referenceFamilyFrontierRest ⟨parameter, 0, ots, fts⟩ f graph auxiliary.selections dummy adversary]
+  pure (auxiliary.selections, result)
+
+theorem referenceResidualGame_eq_prefixCoordinates (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    referenceResidualGame inputs hencoding dummy adversary = referencePrefixCoordinateGame inputs hencoding dummy adversary := by
+  rw [referenceResidualGame_eq_prefixAuxiliary, referencePrefixCoordinateGame]
+  apply congrArg (𝒟[sampleParameter] >>= ·)
+  funext parameter
+  conv_lhs =>
+    enter [2, ots]
+    rw [RetainedObservation.bind_comm 𝒟[sampleFtsSecrets] 𝒟[referenceAuxiliarySample inputs]]
+  rw [RetainedObservation.bind_comm 𝒟[sampleOtsSecrets] 𝒟[referenceAuxiliarySample inputs]]
+  apply congrArg (𝒟[referenceAuxiliarySample inputs] >>= ·)
+  funext auxiliary
+  exact sampleSecretGraph_bind_public (referenceFamilyWords auxiliary.selections dummy)
+    (fun _ _ ots fts graph => do
+      let f := programmedHash parameter ots fts graph
+        (finiteHashAnswer ∅ inputs (canonicalPrefixResidual parameter inputs (hencoding parameter) graph
+          auxiliary.selections auxiliary.rows auxiliary.seed))
+      let result ← 𝒟[referenceFamilyFrontierRest ⟨parameter, 0, ots, fts⟩ f graph auxiliary.selections dummy adversary]
+      pure (auxiliary.selections, result))
+
+noncomputable def referencePrefixJointPriorGame (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) : SPMF (ReferenceFamily × (Bool × SigningBoundaryTrace)) := do
+  let parameter ← 𝒟[sampleParameter]
+  let encoding ← 𝒟[referenceEncodingAuxiliarySample]
+  let words := referenceFamilyWords encoding.selections dummy
+  let high ← 𝒟[PMF.uniformOfFintype CanonicalGraphHighHalves]
+  let exposedValues ← 𝒟[PMF.uniformOfFintype (InitialPublicLabels words)]
+  let labels ← complete (initialAllowed words exposedValues)
+  let seed ← completeRows (fun _ : inputs => none)
+  let ots := coordinateOtsSecrets labels
+  let fts := coordinateFtsSecrets labels
+  let graph := coordinateGraphLabels labels high
+  let f := programmedHash parameter ots fts graph
+    (finiteHashAnswer ∅ inputs (canonicalPrefixResidual parameter inputs (hencoding parameter) graph
+      encoding.selections encoding.rows seed))
+  let result ← 𝒟[referenceFamilyFrontierRest ⟨parameter, 0, ots, fts⟩ f graph encoding.selections dummy adversary]
+  pure (encoding.selections, result)
+
+theorem referencePrefixCoordinateGame_eq_jointPrior (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    referencePrefixCoordinateGame inputs hencoding dummy adversary = referencePrefixJointPriorGame inputs hencoding dummy adversary := by
+  rw [referencePrefixCoordinateGame, referencePrefixJointPriorGame]
+  apply congrArg (𝒟[sampleParameter] >>= ·)
+  funext parameter
+  rw [referenceAuxiliarySample_bind_seed]
+  apply congrArg (𝒟[referenceEncodingAuxiliarySample] >>= ·)
+  funext encoding
+  dsimp only
+  rw [RetainedObservation.bind_comm (completeRows (fun _ : inputs => none))]
+  apply congrArg (𝒟[PMF.uniformOfFintype CanonicalGraphHighHalves] >>= ·)
+  funext high
+  rw [RetainedObservation.bind_comm (completeRows (fun _ : inputs => none))
+    𝒟[PMF.uniformOfFintype (InitialPublicLabels (referenceFamilyWords encoding.selections dummy))]]
+  apply congrArg (𝒟[PMF.uniformOfFintype (InitialPublicLabels (referenceFamilyWords encoding.selections dummy))] >>= ·)
+  funext exposedValues
+  rw [RetainedObservation.bind_comm (completeRows (fun _ : inputs => none))
+    (complete (initialAllowed (referenceFamilyWords encoding.selections dummy) exposedValues))]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/ReferencePrefixResidual.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferencePrefixResidual.lean
new file mode 100644
index 000000000..564e0c566
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferencePrefixResidual.lean
@@ -0,0 +1,71 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Base.FirstSuccessPrefix
+import SphincsSecurity.Proof.Residual.PublicResidualLookup
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def canonicalPrefixResidual (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (seed : inputs → HashOutput) : inputs → HashOutput :=
+  UnrestrictedRowSwap.prefixOverwrite (canonicalEncodingCell parameter inputs hencoding labels)
+    (canonicalEncodingCell_injective parameter inputs hencoding labels) (FirstSuccessPrefix.familyKept selections) rows seed
+
+noncomputable def knownPrefixResidual (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (known : Labels)
+    (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (seed : inputs → HashOutput) : inputs → HashOutput :=
+  UnrestrictedRowSwap.prefixOverwrite (knownEncodingCell parameter inputs hencoding known)
+    (knownEncodingCell_injective parameter inputs hencoding known) (FirstSuccessPrefix.familyKept selections) rows seed
+
+theorem canonicalPrefixResidual_eq_known (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (labels : CanonicalGraphLabels)
+    (hagrees : PublicAgreement words disclosed known (CanonicalCoordinate.value otsSecret ftsSecret labels))
+    (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (seed : inputs → HashOutput) :
+    canonicalPrefixResidual parameter inputs hencoding labels selections rows seed =
+      knownPrefixResidual parameter inputs hencoding known selections rows seed := by
+  unfold canonicalPrefixResidual knownPrefixResidual
+  congr 1
+  exact canonicalEncodingCell_eq_known parameter inputs hencoding words disclosed known otsSecret ftsSecret labels hagrees
+
+theorem knownPrefixResidual_lookup (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (known : Labels)
+    (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (seed : inputs → HashOutput) (input : inputs) :
+    knownPrefixResidual parameter inputs hencoding known selections rows seed input =
+      (knownEncodingRowAt parameter inputs hencoding known input).elim (seed input)
+        (fun row => if FirstSuccessPrefix.familyKept selections row then rows row else seed input) := by
+  cases hrow : knownEncodingRowAt parameter inputs hencoding known input with
+  | none =>
+      exact UnrestrictedRowSwap.prefixOverwrite_outside _ _ _ _ _ input
+        ((knownEncodingRowAt_none parameter inputs hencoding known input).mp hrow)
+  | some row =>
+      have heq := (knownEncodingRowAt_some parameter inputs hencoding known input row).mp hrow
+      rw [← heq]
+      exact UnrestrictedRowSwap.prefixOverwrite_embed _ _ _ _ _ row
+
+theorem knownPrefixResidual_structural (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (known : Labels)
+    (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (seed : inputs → HashOutput)
+    (input : inputs) (position : Position) (hat : AtPosition parameter input.val position) :
+    knownPrefixResidual parameter inputs hencoding known selections rows seed input = seed input := by
+  rw [knownPrefixResidual_lookup,
+    knownEncodingRowAt_structural parameter inputs hencoding known input position hat]
+  rfl
+
+theorem canonicalReferenceResidual_prefix_law (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (labels : CanonicalGraphLabels) (selections : ReferenceFamily) :
+    (FirstSuccessFamily.afterSelect decodeEncodingOutput encodingAttemptLimit decodeEncodingOutput_invalid_nonempty selections).bind
+      (fun rows => (PMF.uniformOfFintype (inputs → HashOutput)).map
+        (fun seed => canonicalReferenceResidual parameter inputs hencoding labels (Function.uncurry rows) seed)) =
+    (FirstSuccessFamily.afterSelect decodeEncodingOutput encodingAttemptLimit decodeEncodingOutput_invalid_nonempty selections).bind
+      (fun rows => (PMF.uniformOfFintype (inputs → HashOutput)).map
+        (fun seed => canonicalPrefixResidual parameter inputs hencoding labels selections (Function.uncurry rows) seed)) :=
+  FirstSuccessPrefix.overwrite_table_eq_prefix decodeEncodingOutput encodingAttemptLimit decodeEncodingOutput_invalid_nonempty
+    selections (canonicalEncodingCell parameter inputs hencoding labels) (canonicalEncodingCell_injective parameter inputs hencoding labels)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/ReferencePrefixSigning.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferencePrefixSigning.lean
new file mode 100644
index 000000000..46477146a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/ReferencePrefixSigning.lean
@@ -0,0 +1,102 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Reference.ReferenceAuxiliarySigning
+import SphincsSecurity.Proof.Ots.ReferencePrefixResidual
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+theorem referenceTableSelection_prefix (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary inputs) (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support) :
+    referenceTableSelection key (programmedHash key.parameter key.otsSecret key.ftsSecret labels
+      (finiteHashAnswer ∅ inputs (canonicalPrefixResidual key.parameter inputs hencoding labels
+        auxiliary.selections auxiliary.rows auxiliary.seed))) = auxiliary.selections := by
+  funext position
+  rw [referenceTableSelection_programmedHash key inputs hencoding]
+  apply FirstSuccessPrefix.select_eq_of_kept decodeEncodingOutput
+    (fun counter => auxiliary.rows (position, counter)) _ (auxiliary.selections position)
+    (referenceAuxiliarySample_select inputs auxiliary hauxiliary position)
+  intro counter hkept
+  simp only [canonicalPrefixResidual, UnrestrictedRowSwap.prefixOverwrite_embed,
+    show FirstSuccessPrefix.familyKept auxiliary.selections (position, counter) from hkept, if_true]
+
+theorem referencePrefix_words (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary inputs) (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support)
+    (dummy : OtsReferenceWords) :
+    referenceFamilyWords auxiliary.selections dummy = canonicalReferenceWords key
+      (programmedHash key.parameter key.otsSecret key.ftsSecret labels
+        (finiteHashAnswer ∅ inputs (canonicalPrefixResidual key.parameter inputs hencoding labels
+          auxiliary.selections auxiliary.rows auxiliary.seed))) dummy := by
+  conv_lhs => rw [← referenceTableSelection_prefix key inputs hencoding labels auxiliary hauxiliary]
+  rw [referenceFamilyWords_selected]
+
+theorem programmedPrefixResidual_outside (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (labels : CanonicalGraphLabels)
+    (hagrees : PublicAgreement words disclosed known (CanonicalCoordinate.value otsSecret ftsSecret labels))
+    (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (seed : inputs → HashOutput) (input : HashInput)
+    (houtside : decodePosition parameter input = none) :
+    programmedHash parameter otsSecret ftsSecret labels
+      (finiteHashAnswer ∅ inputs (canonicalPrefixResidual parameter inputs hencoding labels selections rows seed)) input =
+      finiteHashAnswer ∅ inputs (knownPrefixResidual parameter inputs hencoding known selections rows seed) input := by
+  rw [canonicalPrefixResidual_eq_known parameter inputs hencoding words disclosed known otsSecret ftsSecret labels hagrees]
+  simp only [programmedHash, houtside, Option.elim_none]
+
+theorem frontierSigningRecord_prefix_public (key : SecretKey) (root : Digest) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary inputs) (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support)
+    (dummy : OtsReferenceWords) (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels)
+    (hagrees : PublicAgreement (referenceFamilyWords auxiliary.selections dummy) disclosed known
+      (CanonicalCoordinate.value key.otsSecret key.ftsSecret labels)) (message : Message) :
+    frontierSigningRecord key.parameter root
+        (programmedHash key.parameter key.otsSecret key.ftsSecret labels
+          (finiteHashAnswer ∅ inputs (canonicalPrefixResidual key.parameter inputs hencoding labels
+            auxiliary.selections auxiliary.rows auxiliary.seed)))
+        key.ftsSecret (referenceFamilyWords auxiliary.selections dummy)
+        (canonicalGraphFrontier key.otsSecret labels (referenceFamilyWords auxiliary.selections dummy)) message =
+      completePublicSigningRecord key.ftsSecret <$>
+        publicSigningRecord key.parameter root
+          (finiteHashAnswer ∅ inputs (knownPrefixResidual key.parameter inputs hencoding known
+            auxiliary.selections auxiliary.rows auxiliary.seed))
+          known (referenceFamilyWords auxiliary.selections dummy) auxiliary.selections message := by
+  have h := frontierSigningRecord_eq_public key root
+    (programmedHash key.parameter key.otsSecret key.ftsSecret labels
+      (finiteHashAnswer ∅ inputs (canonicalPrefixResidual key.parameter inputs hencoding labels
+        auxiliary.selections auxiliary.rows auxiliary.seed)))
+    (finiteHashAnswer ∅ inputs (knownPrefixResidual key.parameter inputs hencoding known
+      auxiliary.selections auxiliary.rows auxiliary.seed))
+    (referenceFamilyWords auxiliary.selections dummy) disclosed known
+    (by simpa only [canonicalGraphLabels_programmedHash] using hagrees) message
+    (fun randomness => programmedPrefixResidual_outside key.parameter inputs hencoding _ disclosed known
+      key.otsSecret key.ftsSecret labels hagrees auxiliary.selections auxiliary.rows auxiliary.seed _
+      (decodePosition_message key.parameter (messageDigestPayload root message randomness)))
+  simpa only [canonicalGraphLabels_programmedHash,
+    referenceTableSelection_prefix key inputs hencoding labels auxiliary hauxiliary] using h
+
+theorem fixedBoundaryRun_signWithView_prefix_public (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary inputs) (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support)
+    (dummy : OtsReferenceWords) (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels)
+    (hagrees : PublicAgreement (referenceFamilyWords auxiliary.selections dummy) disclosed known
+      (CanonicalCoordinate.value key.otsSecret key.ftsSecret labels)) (message : Message) :
+    fixedBoundaryRun key.parameter
+        (programmedHash key.parameter key.otsSecret key.ftsSecret labels
+          (finiteHashAnswer ∅ inputs (canonicalPrefixResidual key.parameter inputs hencoding labels
+            auxiliary.selections auxiliary.rows auxiliary.seed))) (signWithView key message) =
+      completePublicSigningRecord key.ftsSecret <$>
+        publicSigningRecord key.parameter key.root
+          (finiteHashAnswer ∅ inputs (knownPrefixResidual key.parameter inputs hencoding known
+            auxiliary.selections auxiliary.rows auxiliary.seed))
+          known (referenceFamilyWords auxiliary.selections dummy) auxiliary.selections message := by
+  rw [fixedBoundaryRun_signWithView_canonical _ _ dummy,
+    ← canonicalGraphLabels_frontier key.parameter key.otsSecret key.ftsSecret _ _ key.root,
+    canonicalGraphLabels_programmedHash, ← referencePrefix_words key inputs hencoding labels auxiliary hauxiliary dummy]
+  exact frontierSigningRecord_prefix_public key key.root inputs hencoding labels auxiliary hauxiliary dummy disclosed known hagrees message
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/SecretProbe.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/SecretProbe.lean
new file mode 100644
index 000000000..7dd8b8303
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/SecretProbe.lean
@@ -0,0 +1,47 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Scheme.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]
+
+namespace Concrete
+
+noncomputable local instance secretProbeSampleableOfFintype {T : Type} [Fintype T] [Nonempty T] : SampleableType T :=
+  SampleableType.ofFintype T
+
+structure FtsSecretProbe where
+  index : Index
+  tree : FtsTree
+  leafIdx : FtsLeaf
+  candidate : Digest
+def FtsSecretProbe.input (parameter : PublicParameter) (probe : FtsSecretProbe) : HashInput :=
+  tweakableHashInput parameter (.ftsLeaf probe.index probe.tree probe.leafIdx)
+    (digestBytes 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⟩
+
+end Concrete
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/TraceCheckpointObserver.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/TraceCheckpointObserver.lean
new file mode 100644
index 000000000..e254c70ed
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/TraceCheckpointObserver.lean
@@ -0,0 +1,46 @@
+import SphincsSecurity.Proof.Reference.ReferenceContactGame
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+
+abbrev FrontierStop := PublicParameter → OtsReferenceWords → OtsFrontierValues → OtsContactTrace.Trace → Prop
+
+variable (stop : FrontierStop) [∀ parameter words frontier, DecidablePred (stop parameter words frontier)]
+
+noncomputable def checkpointSplitRun {Result : Type} (parameter : PublicParameter) (words : OtsReferenceWords)
+    (frontier : OtsFrontierValues) (computation : OracleComp OracleWorld Result) :
+    OracleComp OracleWorld (OtsContactTrace.Trace × (Result × OtsContactTrace.Trace)) := do
+  let middle ← QueryPause.run (stop parameter words frontier)
+    (fun input answer history => history * hashObservationTrace input answer) computation 1
+  let tail ← QueryPause.traced hashObservationTrace middle.2
+  pure (middle.1, tail)
+
+noncomputable def checkpointObserver : FrontierObserver ContactResult := fun parameter words frontier computation =>
+  (fun result => ⟨frontier, result.1, result.2.1, result.2.2⟩) <$>
+    checkpointSplitRun stop parameter words frontier computation
+
+theorem checkpointObserver_trace (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (computation : OracleComp OracleWorld (Bool × SigningBoundaryTrace)) :
+    (fun result : ContactResult => (result.output, result.before * result.after)) <$>
+      checkpointObserver stop parameter words frontier computation = QueryPause.traced hashObservationTrace computation := by
+  have h := QueryPause.trace_resume hashObservationTrace (stop parameter words frontier) computation 1
+  have he : (fun result : (Bool × SigningBoundaryTrace) × OtsContactTrace.Trace => (result.1, 1 * result.2)) <$>
+      QueryPause.traced hashObservationTrace computation = QueryPause.traced hashObservationTrace computation := by
+    simp only [one_mul]
+    change id <$> _ = _
+    exact id_map _
+  simpa only [checkpointObserver, checkpointSplitRun, Functor.map_map, map_bind, map_pure] using h.trans he
+
+theorem checkpointObserver_frontier_trace (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (computation : OracleComp OracleWorld (Bool × SigningBoundaryTrace)) :
+    (fun result : ContactResult => (result.frontier, result.output, result.before * result.after)) <$>
+      checkpointObserver stop parameter words frontier computation =
+        (fun result => (frontier, result)) <$> QueryPause.traced hashObservationTrace computation := by
+  simpa only [checkpointObserver, Functor.map_map] using
+    congrArg (Functor.map (fun result => (frontier, result))) (checkpointObserver_trace stop parameter words frontier computation)
+
+theorem checkpointObserver_contact : checkpointObserver OtsContactTrace.Stopped = contactObserver := rfl
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Ots/VerifierContactWitness.lean b/formal/sphincs/SphincsSecurity/Proof/Ots/VerifierContactWitness.lean
new file mode 100644
index 000000000..6b3197076
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Ots/VerifierContactWitness.lean
@@ -0,0 +1,36 @@
+import SphincsSecurity.Proof.Ots.ReferenceLayerWitness
+import SphincsSecurity.Proof.Ots.OtsTwoEdgeProbability
+import SphincsSecurity.Proof.Ots.OtsDistinctContactProbability
+import SphincsSecurity.Proof.Ots.OtsMarkerContactPartition
+namespace SphincsSecurity.Concrete.OtsVerifierWitness
+
+open _root_.OracleComp OracleSpec OtsContactTrace
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] contacts canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+theorem chainException_contactResult (f : QueryImpl HashSpec Id) (parameter : PublicParameter) (words : OtsReferenceWords)
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (secret : ChainIndex → Digest) (result : ContactResult)
+    (hfrontier : ∀ index, result.frontier lay tree leaf index = frontier f parameter words lay tree leaf secret index)
+    (hexception : ChainException f parameter words lay tree leaf secret (result.before * result.after)) :
+    (∃ index, ForwardChainMatch f (segment parameter words lay tree leaf index) (secret index) (result.before * result.after)) ∨
+      result.TwoEdge parameter words ∨ result.TwoContacts parameter words ∨ result.MarkerContact parameter words := by
+  have hcontact (index : ChainIndex)
+      (h : Seen (segment parameter words lay tree leaf index) (frontier f parameter words lay tree leaf secret index) (result.before * result.after)) :
+      (⟨lay, tree, leaf, index⟩ : OtsPrefix.ChainAddress) ∈ contacts parameter words result.frontier (result.before * result.after) := by
+    rw [mem_contacts]
+    simpa only [hfrontier] using h
+  rcases hexception with hf | ⟨index, ht⟩ | ⟨left, right, hne, hl, hr⟩ | ⟨index, hm, hc⟩
+  · exact Or.inl hf
+  · refine Or.inr (Or.inl ⟨⟨lay, tree, leaf, index⟩, ?_⟩)
+    change SeenTwoEdge _ (result.frontier lay tree leaf index) (result.before * result.after)
+    rw [hfrontier]
+    exact ht
+  · apply Or.inr ∘ Or.inr ∘ Or.inl
+    apply Finset.one_lt_card.mpr
+    refine ⟨⟨lay, tree, leaf, left⟩, hcontact left hl, ⟨lay, tree, leaf, right⟩, hcontact right hr, ?_⟩
+    intro he
+    exact hne (congrArg (fun address : OtsPrefix.ChainAddress => address.2.2.2) he)
+  · exact Or.inr (Or.inr (Or.inr ⟨⟨lay, tree, leaf, index⟩, hm, hcontact index hc⟩))
+
+end SphincsSecurity.Concrete.OtsVerifierWitness
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/BoundaryChargePartition.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/BoundaryChargePartition.lean
new file mode 100644
index 000000000..29f83831f
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/BoundaryChargePartition.lean
@@ -0,0 +1,56 @@
+import SphincsSecurity.Proof.Reference.CausalFrontierAllocation
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+def SigningBoundaryTrace.nonmessageCalls (trace : SigningBoundaryTrace) : Nat :=
+  trace.toList.countP Option.isNone
+
+theorem SigningBoundaryTrace.nonmessageCalls_mul (first second : SigningBoundaryTrace) :
+    (first * second).nonmessageCalls = first.nonmessageCalls + second.nonmessageCalls := by
+  simp only [SigningBoundaryTrace.nonmessageCalls, FreeMonoid.toList_mul, List.countP_append]
+
+theorem SigningBoundaryTrace.partition (trace : SigningBoundaryTrace) :
+    trace.nonmessageCalls + trace.messageCalls.length = trace.hashCalls := by
+  unfold SigningBoundaryTrace.nonmessageCalls SigningBoundaryTrace.messageCalls SigningBoundaryTrace.hashCalls
+  generalize trace.toList = records
+  induction records with
+  | nil => rfl
+  | cons entry records ih =>
+      cases entry <;> simp_all <;> omega
+
+namespace CausalFrontierProgram
+
+def NonmessageHash (parameter : PublicParameter) : OracleWorld.Domain → Prop
+  | .inl _ => False
+  | .inr input => ¬FtsProbeSimulation.MessageHashInput parameter input
+
+noncomputable instance (parameter : PublicParameter) : DecidablePred (NonmessageHash parameter) := Classical.decPred _
+
+noncomputable def nonmessageTraceCharge (parameter : PublicParameter) : TraceCharge parameter where
+  selected := NonmessageHash parameter
+  decidable := inferInstance
+  cost := SigningBoundaryTrace.nonmessageCalls
+  cost_mul := SigningBoundaryTrace.nonmessageCalls_mul
+  uniform := by intro input; exact not_false
+  step := by
+    intro input answer
+    cases input with
+    | inl input => simp [NonmessageHash, signingBoundaryTrace, SigningBoundaryTrace.nonmessageCalls]
+    | inr input =>
+        by_cases hmessage : FtsProbeSimulation.MessageHashInput parameter input <;>
+          simp [NonmessageHash, signingBoundaryTrace, SigningBoundaryTrace.nonmessageCalls, hmessage]
+
+theorem game_nonmessage_recorded_le (parameter : PublicParameter) (external : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (adversary : Adversary) (result : (Bool × SigningBoundaryTrace) × List OracleWorld.Domain)
+    (hresult : result ∈ support (QueryCap.recorded (game parameter external ftsSecret words frontier adversary))) :
+    QueryCap.calls (NonmessageHash parameter) result.2 + result.1.2.messageCalls.length ≤ result.1.2.hashCalls := by
+  have h := QueryCap.recorded_calls_le (NonmessageHash parameter) _ (fun result => result.2.nonmessageCalls)
+    (TraceCharge.game_counted_le (nonmessageTraceCharge parameter) external ftsSecret words frontier adversary) result hresult
+  exact (Nat.add_le_add_right h _).trans_eq (SigningBoundaryTrace.partition result.1.2)
+
+end CausalFrontierProgram
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/BoundaryHashCost.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/BoundaryHashCost.lean
new file mode 100644
index 000000000..e41c17515
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/BoundaryHashCost.lean
@@ -0,0 +1,94 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Reference.BoundaryMessageCost
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+theorem SigningBoundaryTrace.hashCalls_mul (first second : SigningBoundaryTrace) :
+    (first * second).hashCalls = first.hashCalls + second.hashCalls := by
+  simp only [SigningBoundaryTrace.hashCalls, FreeMonoid.toList_mul, List.length_append]
+
+theorem signingBoundaryTrace_hashCalls_eq (parameter : PublicParameter)
+    (input : OracleWorld.Domain) (output : OracleWorld.Range input) :
+    (signingBoundaryTrace parameter input output).hashCalls = if input matches .inr _ then 1 else 0 := by
+  cases input <;> rfl
+
+def BoundaryHashAtLeast {α : Type} (parameter : PublicParameter)
+    (computation : OracleComp OracleWorld α) (cost : Nat) : Prop :=
+  ∀ cache result, result ∈ support (boundaryRun parameter computation cache) → cost ≤ result.1.2.hashCalls
+
+theorem boundaryHashAtLeast_zero {α : Type} (parameter : PublicParameter)
+    (computation : OracleComp OracleWorld α) : BoundaryHashAtLeast parameter computation 0 := by
+  intro _ _ _
+  exact Nat.zero_le _
+
+theorem BoundaryHashAtLeast.mono {α : Type} {parameter : PublicParameter}
+    {computation : OracleComp OracleWorld α} {a b : Nat}
+    (h : BoundaryHashAtLeast parameter computation a) (hba : b ≤ a) :
+    BoundaryHashAtLeast parameter computation b := by
+  intro cache result hr
+  exact hba.trans (h cache result hr)
+
+theorem boundaryHashAtLeast_bind {α β : Type} (parameter : PublicParameter)
+    (first : OracleComp OracleWorld α) (second : α → OracleComp OracleWorld β) (a b : Nat)
+    (hfirst : BoundaryHashAtLeast parameter first a)
+    (hsecond : ∀ value, BoundaryHashAtLeast parameter (second value) b) :
+    BoundaryHashAtLeast parameter (first >>= second) (a + b) := by
+  intro cache result hr
+  rw [boundaryRun_bind, mem_support_bind_iff] at hr
+  obtain ⟨middle, hmiddle, hr⟩ := hr
+  rw [support_map] at hr
+  obtain ⟨last, hlast, rfl⟩ := hr
+  exact (Nat.add_le_add (hfirst cache middle hmiddle) (hsecond middle.1.1 middle.2 last hlast)).trans_eq
+    (SigningBoundaryTrace.hashCalls_mul _ _).symm
+
+theorem boundaryHashAtLeast_hash (parameter : PublicParameter) (input : HashInput) :
+    BoundaryHashAtLeast parameter (oracleHash input) 1 := by
+  intro cache result hr
+  change result ∈ support (boundaryRun parameter
+    (liftM (OracleWorld.query (.inr input)) : OracleComp OracleWorld HashOutput) cache) at hr
+  rw [boundaryRun_query, support_map] at hr
+  obtain ⟨source, _, rfl⟩ := hr
+  exact le_refl _
+
+theorem boundaryHashAtLeast_tweakableHash (traceParameter parameter : PublicParameter)
+    (domain : HashDomain) (payload : HashInput) :
+    BoundaryHashAtLeast traceParameter
+      (liftM (tweakableHash parameter domain payload : OracleComp HashSpec Digest)) 1 := by
+  change BoundaryHashAtLeast traceParameter
+    (oracleHash (tweakableHashInput parameter domain payload) >>= fun output => pure (truncateHash output)) 1
+  exact boundaryHashAtLeast_bind traceParameter _ _ 1 0 (boundaryHashAtLeast_hash _ _)
+    (fun _ => boundaryHashAtLeast_zero _ _)
+
+theorem boundaryRun_bind_query_bound {α β : Type} (parameter : PublicParameter)
+    (computation : OracleComp OracleWorld α) (next : α → OracleComp OracleWorld β)
+    (q : Nat) (hbound : (computation >>= next).IsQueryBoundP (· matches .inr _) q)
+    (cache : QueryCache HashSpec) (result : (α × SigningBoundaryTrace) × QueryCache HashSpec)
+    (hr : result ∈ support (boundaryRun parameter computation cache)) :
+    result.1.2.hashCalls ≤ q ∧ (next result.1.1).IsQueryBoundP (· matches .inr _) (q - result.1.2.hashCalls) := by
+  induction computation using OracleComp.inductionOn generalizing q cache result with
+  | pure value =>
+      simp only [boundaryRun, simulateQ_pure, WriterT.run_pure, StateT.run_pure,
+        support_pure, Set.mem_singleton_iff] at hr
+      subst result
+      simpa only [SigningBoundaryTrace.hashCalls, FreeMonoid.toList_one, List.length_nil,
+        Nat.sub_zero, pure_bind] using And.intro (Nat.zero_le q) hbound
+  | query_bind input continuation ih =>
+      rw [bind_assoc, isQueryBoundP_query_bind_iff] at hbound
+      rw [boundaryRun_bind, boundaryRun_query, mem_support_bind_iff] at hr
+      obtain ⟨middle, hmiddle, hr⟩ := hr
+      rw [support_map] at hmiddle
+      obtain ⟨source, _, rfl⟩ := hmiddle
+      rw [support_map] at hr
+      obtain ⟨last, hlast, rfl⟩ := hr
+      have htail := ih source.1 _ (hbound.2 source.1) source.2 last hlast
+      rw [SigningBoundaryTrace.hashCalls_mul, signingBoundaryTrace_hashCalls_eq]
+      cases input with
+      | inl sample => simpa only [Bool.false_eq_true, ↓reduceIte, Nat.sub_zero, Nat.zero_add] using htail
+      | inr input =>
+          have hpositive : 0 < q := hbound.1.resolve_left (by simp)
+          simp only [↓reduceIte] at htail ⊢
+          exact ⟨by omega, by simpa only [Nat.sub_sub] using htail.2⟩
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/BoundaryHashEvaluation.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/BoundaryHashEvaluation.lean
new file mode 100644
index 000000000..41306e611
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/BoundaryHashEvaluation.lean
@@ -0,0 +1,242 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Reference.BoundaryHashCost
+
+/-! ## AuthenticationQueryCost -/
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+set_option backward.isDefEq.respectTransparency false
+
+def authenticationHashCost (lay : Layer) : Nat :=
+  ∑ level : Fin maxLayerHeight, if level.val < layerHeight lay then 296 * 2 ^ level.val - 1 else 0
+
+def layerMessageHashCost (lay : Layer) : Nat :=
+  if hbelow : lay.val + 1 < numLayers then
+    296 * 2 ^ layerHeight ⟨lay.val + 1, hbelow⟩ - 1
+  else 28659
+
+end SphincsSecurity.Concrete
+
+/-! ## FtsSigningReserve -/
+
+namespace SphincsSecurity.Concrete.FtsProbeSimulation
+
+open _root_.OracleComp OracleSpec ENNReal
+set_option backward.isDefEq.respectTransparency false
+
+theorem tweakableHashInput_tag_eq (parameter : PublicParameter) (first second : HashDomain)
+    (firstPayload secondPayload : HashInput)
+    (heq : tweakableHashInput parameter first firstPayload = tweakableHashInput parameter second secondPayload) :
+    (hashDomainFields first).tag = (hashDomainFields second).tag := by
+  simp only [tweakableHashInput] at heq
+  obtain ⟨hprefix, _⟩ := List.append_inj heq (by simp [tweakBytes_length, bytesLE_length])
+  obtain ⟨htweak, _⟩ := List.append_inj' hprefix (by simp [bytesLE_length])
+  exact congrArg TweakFields.tag (tweakBytes_eq_iff.mp htweak)
+
+end SphincsSecurity.Concrete.FtsProbeSimulation
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+theorem SigningBoundaryTrace.hashCalls_pow_none (cost : Nat) :
+    SigningBoundaryTrace.hashCalls ((FreeMonoid.of none : SigningBoundaryTrace) ^ cost) = cost := by
+  induction cost with
+  | zero => rfl
+  | succ cost ih =>
+      rw [pow_succ, SigningBoundaryTrace.hashCalls_mul, ih]
+      rfl
+
+theorem SigningBoundaryTrace.messageCalls_pow_none (cost : Nat) :
+    SigningBoundaryTrace.messageCalls ((FreeMonoid.of none : SigningBoundaryTrace) ^ cost) = [] := by
+  induction cost with
+  | zero => rfl
+  | succ cost ih =>
+      rw [pow_succ, SigningBoundaryTrace.messageCalls_mul, ih]
+      rfl
+
+noncomputable def boundaryEval {α : Type} (parameter : PublicParameter)
+    (f : QueryImpl HashSpec Id) (computation : OracleComp HashSpec α) : α × SigningBoundaryTrace :=
+  (simulateQ (f.withTrace (fun input output => signingBoundaryTrace parameter (.inr input) output))
+    computation).run
+
+@[simp] theorem boundaryEval_pure {α : Type} (parameter : PublicParameter)
+    (f : QueryImpl HashSpec Id) (value : α) : boundaryEval parameter f (pure value) = (value, 1) := rfl
+
+theorem boundaryEval_fst {α : Type} (parameter : PublicParameter)
+    (f : QueryImpl HashSpec Id) (computation : OracleComp HashSpec α) :
+    (boundaryEval parameter f computation).1 = evalWithAnswerFn f computation := by
+  exact QueryImpl.fst_map_run_withTrace f
+    (fun input output => signingBoundaryTrace parameter (.inr input) output) computation
+
+theorem boundaryEval_bind {α β : Type} (parameter : PublicParameter)
+    (f : QueryImpl HashSpec Id) (first : OracleComp HashSpec α) (next : α → OracleComp HashSpec β) :
+    boundaryEval parameter f (first >>= next) =
+      ((boundaryEval parameter f (next (evalWithAnswerFn f first))).1,
+        (boundaryEval parameter f first).2 *
+          (boundaryEval parameter f (next (evalWithAnswerFn f first))).2) := by
+  simp only [boundaryEval, simulateQ_bind, WriterT.run_bind]
+  rw [← boundaryEval_fst parameter f first]
+  rfl
+
+theorem boundaryEval_tweakableHash (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (domain : HashDomain) (payload : HashInput) (hmessage : (hashDomainFields domain).tag ≠ 9#8) :
+    boundaryEval parameter f (tweakableHash parameter domain payload) =
+      (truncateHash (f (tweakableHashInput parameter domain payload)), FreeMonoid.of none) := by
+  have hn : ¬ FtsProbeSimulation.MessageHashInput parameter (tweakableHashInput parameter domain payload) := by
+    rintro ⟨otherPayload, heq⟩
+    exact hmessage (FtsProbeSimulation.tweakableHashInput_tag_eq parameter domain .message
+      payload otherPayload heq.symm)
+  simp [boundaryEval, tweakableHash, oracleHash, QueryImpl.withTrace_apply,
+    signingBoundaryTrace_nonmessage _ _ _ hn]
+  rfl
+
+theorem boundaryEval_eq_of_snd {α : Type} (parameter : PublicParameter)
+    (f : QueryImpl HashSpec Id) (computation : OracleComp HashSpec α) (trace : SigningBoundaryTrace)
+    (htrace : (boundaryEval parameter f computation).2 = trace) :
+    boundaryEval parameter f computation = (evalWithAnswerFn f computation, trace) := by
+  exact Prod.ext (boundaryEval_fst _ _ _) htrace
+
+theorem boundaryEval_sequenceFin {α : Type} {n : Nat} (parameter : PublicParameter)
+    (f : QueryImpl HashSpec Id) (computation : Fin n → OracleComp HashSpec α) (cost : Fin n → Nat)
+    (hcost : ∀ i, (boundaryEval parameter f (computation i)).2 = (FreeMonoid.of none) ^ cost i) :
+    boundaryEval parameter f (sequenceFin computation) =
+      (fun i => evalWithAnswerFn f (computation i), (FreeMonoid.of none) ^ (∑ i, cost i)) := by
+  rw [← evalWithAnswerFn_sequenceFin]
+  apply boundaryEval_eq_of_snd
+  induction n with
+  | zero => simp [sequenceFin]
+  | succ n ih =>
+      rw [sequenceFin, boundaryEval_bind]
+      have ht := ih (fun i => computation i.succ) (fun i => cost i.succ) (fun i => hcost i.succ)
+      simp only [boundaryEval_bind, boundaryEval_pure, mul_one, hcost, ht,
+        Fin.sum_univ_succ, pow_add]
+
+theorem boundaryEval_chainWalk (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (chainIdx : ChainIndex)
+    (start steps : Nat) (value : Digest) (hsteps : start + steps ≤ chainLength - 1) :
+    boundaryEval parameter f (chainWalk parameter lay tree leaf chainIdx start steps value) =
+      (evalWithAnswerFn f (chainWalk parameter lay tree leaf chainIdx start steps value),
+        (FreeMonoid.of none) ^ steps) := by
+  apply boundaryEval_eq_of_snd
+  induction steps with
+  | zero => simp [chainWalk]
+  | succ steps ih =>
+      have hstep : start + steps < chainLength - 1 := by omega
+      rw [chainWalk, boundaryEval_bind, dif_pos hstep,
+        boundaryEval_tweakableHash _ _ _ _ (by simp [hashDomainFields]), ih (by omega), pow_succ]
+
+theorem boundaryEval_oneTimePublicKey (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (secret : ChainIndex → Digest) :
+    boundaryEval parameter f (oneTimePublicKey parameter lay tree leaf secret) =
+      (evalWithAnswerFn f (oneTimePublicKey parameter lay tree leaf secret), (FreeMonoid.of none) ^ 294) := by
+  rw [oneTimePublicKey]
+  have h := boundaryEval_sequenceFin parameter f
+    (fun chainIdx => chainWalk parameter lay tree leaf chainIdx 0 (chainLength - 1) (secret chainIdx))
+    (fun _ => chainLength - 1)
+    (fun chainIdx => congrArg Prod.snd (boundaryEval_chainWalk _ _ _ _ _ _ _ _ _ (by omega)))
+  simpa only [evalWithAnswerFn_sequenceFin, Finset.sum_const, Finset.card_univ, Fintype.card_fin,
+    smul_eq_mul, show numChains * (chainLength - 1) = 294 from rfl] using h
+
+theorem boundaryEval_treeNode (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (lay : Layer) (tree : TreeIndex) (secret : LeafIndex → ChainIndex → Digest) (level nodeIdx : Nat) :
+    boundaryEval parameter f (treeNode parameter lay tree secret level nodeIdx) =
+      (evalWithAnswerFn f (treeNode parameter lay tree secret level nodeIdx),
+        (FreeMonoid.of none) ^ (296 * 2 ^ level - 1)) := by
+  apply boundaryEval_eq_of_snd
+  induction level generalizing nodeIdx with
+  | zero =>
+      rw [treeNode_zero_eq, boundaryEval_bind, boundaryEval_oneTimePublicKey]
+      simp only [leafHash, boundaryEval_tweakableHash parameter f (.leaf lay tree (leafOfNat nodeIdx)) _
+        (by simp [hashDomainFields])]
+      rw [← pow_succ]
+      congr 1
+  | succ level ih =>
+      rw [treeNode_succ_eq, boundaryEval_bind]
+      simp only [boundaryEval_bind, ih, boundaryEval_tweakableHash parameter f (.node lay tree (level + 1) nodeIdx) _
+        (by simp [hashDomainFields])]
+      rw [← pow_succ, ← pow_add]
+      congr 1
+      have hp : 0 < 2 ^ level := by positivity
+      rw [pow_succ]
+      omega
+
+theorem boundaryEval_treePath (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (lay : Layer) (tree : TreeIndex) (secret : LeafIndex → ChainIndex → Digest) (leaf : LeafIndex) :
+    boundaryEval parameter f (treePath parameter lay tree secret leaf) =
+      (evalWithAnswerFn f (treePath parameter lay tree secret leaf),
+        (FreeMonoid.of none) ^ authenticationHashCost lay) := by
+  unfold treePath authenticationHashCost
+  rw [evalWithAnswerFn_sequenceFin]
+  apply boundaryEval_sequenceFin
+  intro level
+  split_ifs
+  · exact congrArg Prod.snd (boundaryEval_treeNode _ _ _ _ _ _ _)
+  · simp
+
+theorem boundaryEval_ftsNode (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (index : Index) (tree : FtsTree) (secret : FtsLeaf → Digest) (level nodeIdx : Nat) :
+    boundaryEval parameter f (ftsNode parameter index tree secret level nodeIdx) =
+      (evalWithAnswerFn f (ftsNode parameter index tree secret level nodeIdx),
+        (FreeMonoid.of none) ^ (2 ^ (level + 1) - 1)) := by
+  apply boundaryEval_eq_of_snd
+  induction level generalizing nodeIdx with
+  | zero =>
+      rw [ftsNode_zero_eq, ftsLeafHash, boundaryEval_tweakableHash _ _ _ _ (by simp [hashDomainFields])]
+      simp
+  | succ level ih =>
+      rw [ftsNode_succ_eq, boundaryEval_bind]
+      simp only [boundaryEval_bind, ih,
+        boundaryEval_tweakableHash parameter f (.ftsNode index tree (level + 1) nodeIdx) _
+          (by simp [hashDomainFields])]
+      rw [← pow_succ, ← pow_add]
+      congr 1
+      have hp : 0 < 2 ^ (level + 1) := by positivity
+      rw [pow_succ]
+      omega
+
+theorem boundaryEval_ftsKey (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (index : Index) (secret : FtsTree → FtsLeaf → Digest) :
+    boundaryEval parameter f (ftsKey parameter index secret) =
+      (evalWithAnswerFn f (ftsKey parameter index secret), (FreeMonoid.of none) ^ 28659) := by
+  have hroots := boundaryEval_sequenceFin parameter f
+    (fun tree => ftsNode parameter index tree (secret tree) ftsTreeHeight 0)
+    (fun _ => 2 ^ (ftsTreeHeight + 1) - 1)
+    (fun tree => by rw [boundaryEval_ftsNode])
+  have hcost : (∑ _tree : FtsTree, (2 ^ (ftsTreeHeight + 1) - 1)) = 28658 := by
+    simp only [Finset.sum_const, Finset.card_univ, Fintype.card_fin, smul_eq_mul]
+    rfl
+  apply boundaryEval_eq_of_snd
+  rw [ftsKey, boundaryEval_bind, hroots, hcost,
+    boundaryEval_tweakableHash _ _ _ _ (by simp [hashDomainFields]), ← pow_succ]
+
+theorem boundaryEval_ftsOpen (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (index : Index) (leaves : IndexGroup → FtsLeaf) (secret : FtsTree → FtsLeaf → Digest) :
+    boundaryEval parameter f (ftsOpen parameter index leaves secret) =
+      (evalWithAnswerFn f (ftsOpen parameter index leaves secret), (FreeMonoid.of none) ^ 28504) := by
+  apply boundaryEval_eq_of_snd
+  unfold ftsOpen
+  have hcost : (∑ _tree : FtsTree, ∑ level : Fin ftsTreeHeight, (2 ^ (level.val + 1) - 1)) = 28504 := by decide
+  rw [← hcost]
+  apply congrArg Prod.snd (boundaryEval_sequenceFin parameter f _ _ ?_)
+  intro tree
+  apply congrArg Prod.snd (boundaryEval_sequenceFin parameter f _ _ ?_)
+  intro level
+  exact congrArg Prod.snd (boundaryEval_ftsNode _ _ _ _ _ _ _)
+
+theorem boundaryEval_layerMessage (key : SecretKey) (f : QueryImpl HashSpec Id) (index : Index) (lay : Layer) :
+    boundaryEval key.parameter f (layerMessage key index lay) =
+      (evalWithAnswerFn f (layerMessage key index lay), (FreeMonoid.of none) ^ layerMessageHashCost lay) := by
+  rw [layerMessage, layerMessageHashCost]
+  split_ifs
+  · rw [treeRoot]
+    exact boundaryEval_treeNode _ _ _ _ _ _ _
+  · exact boundaryEval_ftsKey _ _ _ _
+
+theorem boundaryEval_hash_query (parameter : PublicParameter) (f : QueryImpl HashSpec Id) (input : HashInput) :
+    boundaryEval parameter f (liftM (HashSpec.query input)) =
+      (f input, signingBoundaryTrace parameter (.inr input) (f input)) := rfl
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/BoundaryMessageCost.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/BoundaryMessageCost.lean
new file mode 100644
index 000000000..2e47b7c39
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/BoundaryMessageCost.lean
@@ -0,0 +1,109 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.SigningProposalRecord
+
+/-! ## JointProbeMessageHashBudget -/
+
+namespace SphincsSecurity.Concrete.FtsProbeSimulation
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def messageHashCharge (parameter : PublicParameter) (_ : QueryCache HashSpec) (input : HashInput) : ENNReal :=
+  if MessageHashInput parameter input then 1 else 0
+
+end SphincsSecurity.Concrete.FtsProbeSimulation
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+open FtsProbeSimulation (messageHashCharge)
+attribute [local instance] Classical.propDecidable
+
+noncomputable def boundaryRun {α : Type} (parameter : PublicParameter)
+    (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec) :
+    ProbComp ((α × SigningBoundaryTrace) × QueryCache HashSpec) :=
+  ((simulateQ (romImpl.withTrace (signingBoundaryTrace parameter)) computation).run).run cache
+
+theorem boundaryRun_forget {α : Type} (parameter : PublicParameter)
+    (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec) :
+    (fun result => (result.1.1, result.2)) <$> boundaryRun parameter computation cache =
+      (simulateQ romImpl computation).run cache := by
+  have h := congrArg (fun comp : StateT (QueryCache HashSpec) ProbComp α => comp.run cache)
+    (QueryImpl.fst_map_run_withTrace romImpl (signingBoundaryTrace parameter) computation)
+  simpa only [StateT.run_map, boundaryRun] using h
+
+theorem boundaryRun_bind {α β : Type} (parameter : PublicParameter)
+    (computation : OracleComp OracleWorld α) (next : α → OracleComp OracleWorld β)
+    (cache : QueryCache HashSpec) :
+    boundaryRun parameter (computation >>= next) cache =
+      boundaryRun parameter computation cache >>= fun first =>
+        (fun second => ((second.1.1, first.1.2 * second.1.2), second.2)) <$>
+          boundaryRun parameter (next first.1.1) first.2 := by
+  simp only [boundaryRun, simulateQ_bind, WriterT.run_bind, StateT.run_bind, StateT.run_map]
+
+theorem boundaryRun_query (parameter : PublicParameter)
+    (input : OracleWorld.Domain) (cache : QueryCache HashSpec) :
+    boundaryRun parameter (OracleSpec.query input) cache =
+      (fun result => ((result.1, signingBoundaryTrace parameter input result.1), result.2)) <$>
+        (romImpl input).run cache := by
+  simp [boundaryRun, QueryImpl.withTrace_apply]
+
+theorem SigningBoundaryTrace.messageCalls_mul (first second : SigningBoundaryTrace) :
+    (first * second).messageCalls = first.messageCalls ++ second.messageCalls := by
+  simp only [SigningBoundaryTrace.messageCalls, FreeMonoid.toList_mul, List.filterMap_append]
+
+noncomputable def expectedBoundaryMessageCalls {α : Type} (parameter : PublicParameter)
+    (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec) : ENNReal :=
+  ∑' result, Pr[= result | boundaryRun parameter computation cache] * result.1.2.messageCalls.length
+
+@[simp] theorem expectedBoundaryMessageCalls_pure {α : Type} (parameter : PublicParameter)
+    (value : α) (cache : QueryCache HashSpec) :
+    expectedBoundaryMessageCalls parameter (pure value) cache = 0 := by
+  simp [expectedBoundaryMessageCalls, boundaryRun, SigningBoundaryTrace.messageCalls]
+
+theorem expectedBoundaryMessageCalls_bind {α β : Type} (parameter : PublicParameter)
+    (computation : OracleComp OracleWorld α) (next : α → OracleComp OracleWorld β)
+    (cache : QueryCache HashSpec) :
+    expectedBoundaryMessageCalls parameter (computation >>= next) cache =
+      expectedBoundaryMessageCalls parameter computation cache +
+        ∑' result, Pr[= result | (simulateQ romImpl computation).run cache] *
+          expectedBoundaryMessageCalls parameter (next result.1) result.2 := by
+  rw [expectedBoundaryMessageCalls, boundaryRun_bind, tsum_probOutput_bind_mul]
+  simp_rw [tsum_probOutput_map_mul, SigningBoundaryTrace.messageCalls_mul, List.length_append,
+    Nat.cast_add, mul_add, ENNReal.tsum_add, ENNReal.tsum_mul_right]
+  simp only [tsum_probOutput_of_liftM_PMF, one_mul]
+  rw [← boundaryRun_forget parameter computation cache, tsum_probOutput_map_mul]
+  simp only [expectedBoundaryMessageCalls, mul_add, ENNReal.tsum_add]
+
+theorem signingBoundaryTrace_messageCalls (parameter : PublicParameter)
+    (input : OracleWorld.Domain) (output : OracleWorld.Range input) (cache : QueryCache HashSpec) :
+    ((signingBoundaryTrace parameter input output).messageCalls.length : ENNReal) =
+      hashQueryCharge (messageHashCharge parameter) cache input := by
+  cases input with
+  | inl input => simp [signingBoundaryTrace, SigningBoundaryTrace.messageCalls, hashQueryCharge]
+  | inr input =>
+      by_cases hinput : FtsProbeSimulation.MessageHashInput parameter input <;>
+        simp [signingBoundaryTrace, SigningBoundaryTrace.messageCalls, messageHashCharge,
+          hashQueryCharge, hinput]
+
+theorem expectedBoundaryMessageCalls_query (parameter : PublicParameter)
+    (input : OracleWorld.Domain) (cache : QueryCache HashSpec) :
+    expectedBoundaryMessageCalls parameter (OracleSpec.query input) cache =
+      hashQueryCharge (messageHashCharge parameter) cache input := by
+  rw [expectedBoundaryMessageCalls, boundaryRun_query, tsum_probOutput_map_mul]
+  simp only [signingBoundaryTrace_messageCalls parameter input _ cache,
+    ENNReal.tsum_mul_right, romImpl_query_mass, one_mul]
+
+theorem expectedBoundaryMessageCalls_eq_queryCharge {α : Type} (parameter : PublicParameter)
+    (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec) :
+    expectedBoundaryMessageCalls parameter computation cache =
+      expectedQueryCharge (messageHashCharge parameter) computation cache := by
+  induction computation using OracleComp.inductionOn generalizing cache with
+  | pure value => simp only [expectedBoundaryMessageCalls_pure, expectedQueryCharge_pure]
+  | query_bind input next ih =>
+      rw [expectedBoundaryMessageCalls_bind, expectedQueryCharge_query_bind,
+        expectedBoundaryMessageCalls_query, simulateQ_spec_query]
+      simp only [ih]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/BoundarySimulation.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/BoundarySimulation.lean
new file mode 100644
index 000000000..ee29420a3
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/BoundarySimulation.lean
@@ -0,0 +1,63 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Reference.FixedHashBoundary
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+theorem simulateQ_writer_compose {ι₁ ι₂ α ω : Type} {spec₁ : OracleSpec ι₁} {spec₂ : OracleSpec ι₂}
+    {m : Type → Type} [Monad m] [LawfulMonad m] [Monoid ω]
+    (first : QueryImpl spec₁ (WriterT ω (OracleComp spec₂))) (second : QueryImpl spec₂ m)
+    (combined : QueryImpl spec₁ (WriterT ω m))
+    (hquery : ∀ input, simulateQ second (first input).run = (combined input).run)
+    (computation : OracleComp spec₁ α) :
+    simulateQ second (simulateQ first computation).run = (simulateQ combined computation).run := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => simp
+  | query_bind input next ih =>
+      simp only [simulateQ_bind, WriterT.run_bind, simulateQ_spec_query, simulateQ_map, hquery]
+      apply bind_congr
+      rintro ⟨output, trace⟩
+      rw [ih]
+
+theorem simulateQ_writerAppend_compose {ι₁ ι₂ α ω : Type} {spec₁ : OracleSpec ι₁} {spec₂ : OracleSpec ι₂}
+    {m : Type → Type} [Monad m] [LawfulMonad m] [EmptyCollection ω] [Append ω] [LawfulAppend ω]
+    (first : QueryImpl spec₁ (WriterT ω (OracleComp spec₂))) (second : QueryImpl spec₂ m)
+    (combined : QueryImpl spec₁ (WriterT ω m))
+    (hquery : ∀ input, simulateQ second (first input).run = (combined input).run)
+    (computation : OracleComp spec₁ α) :
+    simulateQ second (simulateQ first computation).run = (simulateQ combined computation).run := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => simp
+  | query_bind input next ih =>
+      simp only [simulateQ_bind, WriterT.run_bind', simulateQ_spec_query, simulateQ_map, hquery]
+      apply bind_congr
+      rintro ⟨output, trace⟩
+      rw [ih]
+
+noncomputable def boundaryComputation {α : Type} (parameter : PublicParameter)
+    (computation : OracleComp OracleWorld α) : OracleComp OracleWorld (α × SigningBoundaryTrace) :=
+  (simulateQ ((QueryImpl.id' OracleWorld).withTrace (signingBoundaryTrace parameter)) computation).run
+
+theorem simulateQ_boundaryComputation {α : Type} {m : Type → Type} [Monad m] [LawfulMonad m]
+    (parameter : PublicParameter) (impl : QueryImpl OracleWorld m) (computation : OracleComp OracleWorld α) :
+    simulateQ impl (boundaryComputation parameter computation) =
+      (simulateQ (impl.withTrace (signingBoundaryTrace parameter)) computation).run := by
+  apply simulateQ_writer_compose
+  intro input
+  simp [QueryImpl.withTrace_apply]
+
+theorem boundaryRun_fst_eq_boundaryComputation {α : Type} (parameter : PublicParameter)
+    (computation : OracleComp OracleWorld α) (cache : QueryCache HashSpec) :
+    Prod.fst <$> boundaryRun parameter computation cache =
+      (simulateQ romImpl (boundaryComputation parameter computation)).run' cache := by
+  rw [simulateQ_boundaryComputation, StateT.run'_eq]
+  rfl
+
+theorem fixedBoundaryRun_eq_boundaryComputation {α : Type} (parameter : PublicParameter)
+    (f : QueryImpl HashSpec Id) (computation : OracleComp OracleWorld α) :
+    fixedBoundaryRun parameter f computation =
+      simulateQ (fixedHashWorld f) (boundaryComputation parameter computation) :=
+  (simulateQ_boundaryComputation parameter (fixedHashWorld f) computation).symm
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/CausalFrontierAllocation.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/CausalFrontierAllocation.lean
new file mode 100644
index 000000000..8ee8f426b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/CausalFrontierAllocation.lean
@@ -0,0 +1,131 @@
+import SphincsSecurity.Proof.Reference.CausalFrontierProgram
+import SphincsSecurity.Proof.Reference.QueryAllocation
+namespace SphincsSecurity.Concrete.CausalFrontierProgram
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] frontierSigningRun boundaryEval frontierRoot
+
+def IsHash : OracleWorld.Domain → Prop := (· matches .inr _)
+
+instance : DecidablePred IsHash := fun input => by unfold IsHash; infer_instance
+
+structure TraceCharge (parameter : PublicParameter) where
+  selected : OracleWorld.Domain → Prop
+  decidable : DecidablePred selected
+  cost : SigningBoundaryTrace → Nat
+  cost_mul : ∀ first second, cost (first * second) = cost first + cost second
+  uniform : ∀ input, ¬selected (.inl input)
+  step : ∀ input answer, (if selected input then 1 else 0) ≤ cost (signingBoundaryTrace parameter input answer)
+
+namespace TraceCharge
+
+variable {parameter : PublicParameter} (charge : TraceCharge parameter)
+
+noncomputable instance : DecidablePred charge.selected := charge.decidable
+
+theorem lift_prob_queryBound {Result : Type} (computation : ProbComp Result) :
+    (liftM computation : OracleComp OracleWorld Result).IsQueryBoundP charge.selected 0 := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => simp only [liftM_pure, isQueryBoundP_pure]
+  | query_bind input next ih =>
+      rw [liftM_bind]
+      change ((liftM (OracleWorld.query (.inl input)) >>= fun answer => liftM (next answer)) :
+        OracleComp OracleWorld Result).IsQueryBoundP charge.selected 0
+      simp only [isQueryBoundP_query_bind_iff, charge.uniform, not_false_eq_true, true_or, ↓reduceIte, true_and]
+      exact ih
+
+private theorem withTrace_run {Input Trace : Type} {spec : OracleSpec Input} [Monoid Trace]
+    (trace : (input : spec.Domain) → spec.Range input → Trace) (input : spec.Domain) :
+    ((QueryImpl.id' spec).withTrace trace input).run =
+      (fun answer => (answer, trace input answer)) <$> (liftM (spec.query input) : OracleComp spec _) := by
+  simp [QueryImpl.withTrace_apply, WriterT.run_bind, WriterT.run_tell]
+
+theorem worldTrace_counted_le (input : OracleWorld.Domain)
+    (result : (OracleWorld.Range input × SigningBoundaryTrace) × Nat)
+    (hresult : result ∈ support (QueryCap.counted charge.selected
+      ((QueryImpl.id' OracleWorld).withTrace (signingBoundaryTrace parameter) input).run)) :
+    result.2 ≤ charge.cost result.1.2 := by
+  rw [withTrace_run, QueryCap.counted_map, support_map] at hresult
+  obtain ⟨original, horiginal, rfl⟩ := hresult
+  rw [QueryCap.counted_query, support_map] at horiginal
+  obtain ⟨answer, _, rfl⟩ := horiginal
+  exact charge.step input answer
+
+theorem boundary_counted_le {Result : Type} (computation : OracleComp OracleWorld Result)
+    (result : (Result × SigningBoundaryTrace) × Nat)
+    (hresult : result ∈ support (QueryCap.counted charge.selected (boundaryComputation parameter computation))) :
+    result.2 ≤ charge.cost result.1.2 :=
+  QueryCap.counted_writer_simulate_le _ charge.cost charge.cost_mul _
+    (worldTrace_counted_le charge) computation result hresult
+
+theorem adversaryImpl_counted_le (root : Digest)
+    (external : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) (input : (OracleWorld + SigningSpec).Domain)
+    (result : ((OracleWorld + SigningSpec).Range input × SigningBoundaryTrace) × Nat)
+    (hresult : result ∈ support (QueryCap.counted charge.selected
+      (adversaryImpl parameter root external ftsSecret words frontier input).run)) : result.2 ≤ charge.cost result.1.2 := by
+  cases input with
+  | inl input => exact worldTrace_counted_le charge input result hresult
+  | inr message =>
+      rw [adversaryImpl_signing, WriterT.run_mk] at hresult
+      have hzero := QueryCap.counted_le_of_queryBound _ _ 0 (lift_prob_queryBound charge _) result hresult
+      exact hzero.trans (Nat.zero_le _)
+
+theorem adversaryRun_counted_le {Result : Type} (root : Digest)
+    (external : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (result : ((Result × QueryLog SigningSpec) × SigningBoundaryTrace) × Nat)
+    (hresult : result ∈ support (QueryCap.counted charge.selected
+      (adversaryRun parameter root external ftsSecret words frontier computation))) : result.2 ≤ charge.cost result.1.2 :=
+  QueryCap.counted_writer_simulate_le _ charge.cost charge.cost_mul _
+    (adversaryImpl_counted_le charge root external ftsSecret words frontier) (OtsPrefix.logged computation) result hresult
+
+theorem gameRest_counted_le (root : Digest)
+    (external : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) (adversary : Adversary)
+    (result : (Bool × SigningBoundaryTrace) × Nat)
+    (hresult : result ∈ support (QueryCap.counted charge.selected
+      (gameRest parameter root external ftsSecret words frontier adversary))) : result.2 ≤ charge.cost result.1.2 := by
+  simp only [gameRest, QueryCap.counted_bind, QueryCap.counted_pure, bind_assoc, pure_bind, Nat.add_zero] at hresult
+  rw [mem_support_bind_iff] at hresult
+  obtain ⟨first, hfirst, hresult⟩ := hresult
+  rw [mem_support_bind_iff] at hresult
+  obtain ⟨second, hsecond, hresult⟩ := hresult
+  rw [mem_support_pure_iff] at hresult
+  subst result
+  rw [charge.cost_mul]
+  exact Nat.add_le_add (adversaryRun_counted_le charge root external ftsSecret words frontier _ first hfirst)
+    (boundary_counted_le charge _ second hsecond)
+
+theorem game_counted_le (external : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (adversary : Adversary) (result : (Bool × SigningBoundaryTrace) × Nat)
+    (hresult : result ∈ support (QueryCap.counted charge.selected
+      (game parameter external ftsSecret words frontier adversary))) : result.2 ≤ charge.cost result.1.2 := by
+  rw [game, QueryCap.counted_map, support_map] at hresult
+  obtain ⟨original, horiginal, rfl⟩ := hresult
+  have h := gameRest_counted_le charge _ external ftsSecret words frontier adversary original horiginal
+  simp only [charge.cost_mul]
+  omega
+
+end TraceCharge
+
+noncomputable def hashTraceCharge (parameter : PublicParameter) : TraceCharge parameter where
+  selected := IsHash
+  decidable := inferInstance
+  cost := SigningBoundaryTrace.hashCalls
+  cost_mul := SigningBoundaryTrace.hashCalls_mul
+  uniform := by intro input; simp [IsHash]
+  step := by
+    intro input answer
+    cases input <;> simp [IsHash, signingBoundaryTrace_hashCalls_eq]
+
+theorem game_counted_le (parameter : PublicParameter) (external : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (adversary : Adversary) (result : (Bool × SigningBoundaryTrace) × Nat)
+    (hresult : result ∈ support (QueryCap.counted IsHash
+      (game parameter external ftsSecret words frontier adversary))) : result.2 ≤ result.1.2.hashCalls :=
+  TraceCharge.game_counted_le (hashTraceCharge parameter) external ftsSecret words frontier adversary result hresult
+
+end SphincsSecurity.Concrete.CausalFrontierProgram
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/CausalFrontierGame.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/CausalFrontierGame.lean
new file mode 100644
index 000000000..ad99f68ed
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/CausalFrontierGame.lean
@@ -0,0 +1,82 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.FrontierSigningOracleCongruence
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] boundaryEval
+
+noncomputable def causalFrontierAdversaryImpl (parameter : PublicParameter) (root : Digest)
+    (external : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) :
+    QueryImpl (OracleWorld + SigningSpec) (WriterT SigningBoundaryTrace ProbComp)
+  | .inl input => (fixedHashWorld external).withTrace (signingBoundaryTrace parameter) input
+  | .inr message => WriterT.mk
+      (frontierSigningRun parameter root (maskOtsPrefixes parameter words external) ftsSecret words frontier message)
+
+theorem causalFrontierAdversaryImpl_eq (parameter : PublicParameter) (root : Digest)
+    (f : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) :
+    causalFrontierAdversaryImpl parameter root f ftsSecret words frontier =
+      frontierAdversaryImpl parameter root f ftsSecret words frontier := by
+  funext input
+  cases input with
+  | inl input => rfl
+  | inr message =>
+      change (WriterT.mk
+        (frontierSigningRun parameter root (maskOtsPrefixes parameter words f) ftsSecret words frontier message) :
+          WriterT SigningBoundaryTrace ProbComp (Option Signature)) =
+        WriterT.mk (frontierSigningRun parameter root f ftsSecret words frontier message)
+      rw [← frontierSigningRun_eq_of_agree parameter words f (maskOtsPrefixes parameter words f)
+        (maskOtsPrefixes_agrees parameter words f)]
+
+noncomputable def causalFrontierAdversaryRun {α : Type} (parameter : PublicParameter) (root : Digest)
+    (external : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) :
+    ProbComp ((α × QueryLog SigningSpec) × SigningBoundaryTrace) :=
+  ((simulateQ ((causalFrontierAdversaryImpl parameter root external ftsSecret words frontier).withTraceAppend signingLogFragment)
+    computation).run).run
+
+theorem causalFrontierAdversaryRun_eq {α : Type} (parameter : PublicParameter) (root : Digest)
+    (f : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (computation : OracleComp (OracleWorld + SigningSpec) α) :
+    causalFrontierAdversaryRun parameter root f ftsSecret words frontier computation =
+      frontierAdversaryRun parameter root f ftsSecret words frontier computation := by
+  rw [causalFrontierAdversaryRun, frontierAdversaryRun, causalFrontierAdversaryImpl_eq]
+
+noncomputable def causalFrontierGameRest (parameter : PublicParameter) (root : Digest)
+    (external : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) (adversary : Adversary) :
+    ProbComp (Bool × SigningBoundaryTrace) := do
+  let result ← causalFrontierAdversaryRun parameter root external ftsSecret words frontier
+    (adversary.main ⟨root, parameter⟩)
+  let checked := boundaryEval parameter external (verify ⟨root, parameter⟩ result.1.1.message result.1.1.signature)
+  pure (decide (SigningTranscript.Valid result.1.2 ∧ ¬SigningTranscript.Contains result.1.2 result.1.1) && checked.1,
+    result.2 * checked.2)
+
+theorem causalFrontierGameRest_eq (parameter : PublicParameter) (root : Digest)
+    (f : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) (adversary : Adversary) :
+    causalFrontierGameRest parameter root f ftsSecret words frontier adversary =
+      frontierGameRest parameter root f ftsSecret words frontier adversary := by
+  rw [causalFrontierGameRest, frontierGameRest, causalFrontierAdversaryRun_eq]
+
+noncomputable def causalFrontierGame (parameter : PublicParameter) (external : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords)
+    (frontier : OtsFrontierValues) (adversary : Adversary) : ProbComp (Bool × SigningBoundaryTrace) :=
+  (fun result => (result.1, (FreeMonoid.of none) ^ 1212415 * result.2)) <$>
+    causalFrontierGameRest parameter (frontierRoot parameter (maskOtsPrefixes parameter words external) words frontier)
+      external ftsSecret words frontier adversary
+
+theorem causalFrontierGame_eq (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords)
+    (frontier : OtsFrontierValues) (adversary : Adversary) :
+    causalFrontierGame parameter f ftsSecret words frontier adversary =
+      frontierGame parameter f ftsSecret words frontier adversary := by
+  rw [causalFrontierGame, frontierGame, causalFrontierGameRest_eq,
+    ← frontierRoot_eq_of_agree parameter words f (maskOtsPrefixes parameter words f)
+      (maskOtsPrefixes_agrees parameter words f)]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/CausalFrontierProgram.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/CausalFrontierProgram.lean
new file mode 100644
index 000000000..c7127bac4
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/CausalFrontierProgram.lean
@@ -0,0 +1,129 @@
+import SphincsSecurity.Proof.Ots.OtsPrefixSimulation
+namespace SphincsSecurity.Concrete.CausalFrontierProgram
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] frontierSigningRun boundaryEval frontierRoot
+
+noncomputable def adversaryImpl (parameter : PublicParameter) (root : Digest)
+    (external : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) :
+    QueryImpl (OracleWorld + SigningSpec) (WriterT SigningBoundaryTrace (OracleComp OracleWorld))
+  | .inl input => (QueryImpl.id' OracleWorld).withTrace (signingBoundaryTrace parameter) input
+  | .inr message => WriterT.mk (liftM
+      (frontierSigningRun parameter root (maskOtsPrefixes parameter words external) ftsSecret words frontier message))
+
+theorem adversaryImpl_signing (parameter : PublicParameter) (root : Digest)
+    (external : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) (message : Message) :
+    adversaryImpl parameter root external ftsSecret words frontier (.inr message) =
+      WriterT.mk (liftM (frontierSigningRun parameter root (maskOtsPrefixes parameter words external)
+        ftsSecret words frontier message) : OracleComp OracleWorld _) := rfl
+
+noncomputable def adversaryRun {Result : Type} (parameter : PublicParameter) (root : Digest)
+    (external : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) :
+    OracleComp OracleWorld ((Result × QueryLog SigningSpec) × SigningBoundaryTrace) :=
+  (simulateQ (adversaryImpl parameter root external ftsSecret words frontier) (OtsPrefix.logged computation)).run
+
+noncomputable def gameRest (parameter : PublicParameter) (root : Digest)
+    (external : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) (adversary : Adversary) :
+    OracleComp OracleWorld (Bool × SigningBoundaryTrace) := do
+  let result ← adversaryRun parameter root external ftsSecret words frontier (adversary.main ⟨root, parameter⟩)
+  let checked ← boundaryComputation parameter (liftM
+    (verify ⟨root, parameter⟩ result.1.1.message result.1.1.signature : OracleComp HashSpec Bool))
+  pure (decide (SigningTranscript.Valid result.1.2 ∧ ¬SigningTranscript.Contains result.1.2 result.1.1) && checked.1,
+    result.2 * checked.2)
+
+noncomputable def game (parameter : PublicParameter) (external : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords)
+    (frontier : OtsFrontierValues) (adversary : Adversary) : OracleComp OracleWorld (Bool × SigningBoundaryTrace) :=
+  (fun result => (result.1, (FreeMonoid.of none) ^ 1212415 * result.2)) <$>
+    gameRest parameter (frontierRoot parameter (maskOtsPrefixes parameter words external) words frontier)
+      external ftsSecret words frontier adversary
+
+theorem worldImpl_lift_prob (segment : OtsPrefix) (high : segment.Query → OtsPrefix.High)
+    (outside : QueryImpl HashSpec Id) {Result : Type} (computation : ProbComp Result) :
+    simulateQ (segment.worldImpl high outside) (liftM computation) =
+      (liftM computation : OracleComp segment.World Result) := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => simp only [liftM_pure, simulateQ_pure]
+  | query_bind input next ih =>
+      simp only [liftM_bind, simulateQ_bind, ih]
+      rfl
+
+theorem prefix_boundary (segment : OtsPrefix) (high : segment.Query → OtsPrefix.High)
+    (outside : QueryImpl HashSpec Id) {Result : Type} (computation : OracleComp OracleWorld Result) :
+    simulateQ (segment.worldImpl high outside) (boundaryComputation segment.parameter computation) =
+      segment.boundary high outside computation := by
+  apply simulateQ_writer_compose
+  intro input
+  simp [QueryImpl.withTrace_apply]
+
+theorem prefix_adversaryImpl (segment : OtsPrefix) (root : Digest) (high : segment.Query → OtsPrefix.High)
+    (outside : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) (input : (OracleWorld + SigningSpec).Domain) :
+    simulateQ (segment.worldImpl high outside)
+        (adversaryImpl segment.parameter root outside ftsSecret words frontier input).run =
+      (segment.adversaryImpl root high outside ftsSecret words frontier input).run := by
+  cases input with
+  | inl input => simp [adversaryImpl, OtsPrefix.adversaryImpl, QueryImpl.withTrace_apply]
+  | inr message =>
+      rw [adversaryImpl_signing, OtsPrefix.adversaryImpl_signing, WriterT.run_mk, WriterT.run_mk,
+        worldImpl_lift_prob]
+
+theorem prefix_adversaryRun (segment : OtsPrefix) (root : Digest) (high : segment.Query → OtsPrefix.High)
+    (outside : QueryImpl HashSpec Id) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) {Result : Type}
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) :
+    simulateQ (segment.worldImpl high outside)
+        (adversaryRun segment.parameter root outside ftsSecret words frontier computation) =
+      segment.adversaryRun root high outside ftsSecret words frontier computation :=
+  simulateQ_writer_compose _ _ _ (prefix_adversaryImpl segment root high outside ftsSecret words frontier) _
+
+theorem prefix_game (segment : OtsPrefix) (high : segment.Query → OtsPrefix.High) (outside : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (adversary : Adversary) :
+    simulateQ (segment.worldImpl high outside) (game segment.parameter outside ftsSecret words frontier adversary) =
+      segment.game high outside ftsSecret words frontier adversary := by
+  simp only [game, simulateQ_map, gameRest, simulateQ_bind, prefix_adversaryRun, prefix_boundary, simulateQ_pure,
+    OtsPrefix.game, OtsPrefix.gameRest]
+
+theorem fixed_game (parameter : PublicParameter) (external : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords)
+    (frontier : OtsFrontierValues) (adversary : Adversary) :
+    simulateQ (fixedHashWorld external) (game parameter external ftsSecret words frontier adversary) =
+      frontierGame parameter external ftsSecret words frontier adversary := by
+  let chain : ChainIndex := ⟨0, by decide⟩
+  let segment : OtsPrefix := ⟨parameter, topLayer, rootTree, 0, chain, words topLayer rootTree 0 chain⟩
+  have h := prefix_game segment (segment.highs external) external ftsSecret words frontier adversary
+  apply_fun simulateQ (segment.fixedImpl (segment.lows external)) at h
+  rw [segment.fixedImpl_game_original external ftsSecret words (by rfl) frontier adversary] at h
+  rw [← QueryImpl.simulateQ_compose] at h
+  have himpl : (segment.fixedImpl (segment.lows external)).compose
+      (segment.worldImpl (segment.highs external) external) = fixedHashWorld external := by
+    funext input
+    rw [QueryImpl.apply_compose, segment.fixedImpl_worldImpl, segment.answer_original]
+  simpa only [himpl] using h
+
+theorem fixed_adversaryRun {Result : Type} (parameter : PublicParameter) (root : Digest) (external : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) :
+    simulateQ (fixedHashWorld external) (adversaryRun parameter root external ftsSecret words frontier computation) =
+      frontierAdversaryRun parameter root external ftsSecret words frontier computation := by
+  let chain : ChainIndex := ⟨0, by decide⟩
+  let segment : OtsPrefix := ⟨parameter, topLayer, rootTree, 0, chain, words topLayer rootTree 0 chain⟩
+  have h := prefix_adversaryRun segment root (segment.highs external) external ftsSecret words frontier computation
+  apply_fun simulateQ (segment.fixedImpl (segment.lows external)) at h
+  rw [segment.fixedImpl_adversaryRun _ root _ external ftsSecret words (by rfl) frontier computation,
+    segment.answer_original, causalFrontierAdversaryRun_eq] at h
+  rw [← QueryImpl.simulateQ_compose] at h
+  have himpl : (segment.fixedImpl (segment.lows external)).compose
+      (segment.worldImpl (segment.highs external) external) = fixedHashWorld external := by
+    funext input
+    rw [QueryImpl.apply_compose, segment.fixedImpl_worldImpl, segment.answer_original]
+  simpa only [himpl] using h
+
+end SphincsSecurity.Concrete.CausalFrontierProgram
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/CausalPublicSigning.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/CausalPublicSigning.lean
new file mode 100644
index 000000000..e6d6af051
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/CausalPublicSigning.lean
@@ -0,0 +1,150 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.MessageByteTrace
+namespace SphincsSecurity.Concrete.ResidualByteFrontend
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs publicDigestLoop
+set_option backward.isDefEq.respectTransparency false
+
+theorem messageOnly_map {A B : Type} (parameter : PublicParameter) (f : A → B)
+    (computation : OracleComp OracleWorld A) (hmessage : MessageOnly parameter computation) :
+    MessageOnly parameter (f <$> computation) := by
+  rw [map_eq_bind_pure_comp]
+  exact messageOnly_bind parameter computation (pure ∘ f) hmessage (fun value => messageOnly_pure parameter (f value))
+
+theorem hashInputs_map {A B : Type} (f : A → B) (computation : OracleComp OracleWorld A) :
+    hashInputs (f <$> computation) = hashInputs computation := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => simp only [map_pure, hashInputs_pure]
+  | query_bind input next ih =>
+      simp only [map_bind, hashInputs_query_bind, ih]
+      cases input <;> rfl
+
+theorem hashInputs_boundary {Result : Type} (parameter : PublicParameter) (computation : OracleComp OracleWorld Result) :
+    hashInputs (boundaryComputation parameter computation) = hashInputs computation := by
+  rw [← hashInputs_map Prod.fst, boundaryComputation_fst]
+
+theorem hashInputs_bind_pure_next {A B : Type} (first : OracleComp OracleWorld A) (next : A → OracleComp OracleWorld B)
+    (hpure : ∀ value, ∃ output, next value = pure output) : hashInputs (first >>= next) = hashInputs first := by
+  induction first using OracleComp.inductionOn with
+  | pure value =>
+      obtain ⟨output, heq⟩ := hpure value
+      simp only [pure_bind, heq, hashInputs_pure]
+  | query_bind input tail ih =>
+      simp only [bind_assoc, hashInputs_query_bind, ih]
+      cases input <;> rfl
+
+theorem hashInputs_left_subset {A B : Type} (first : OracleComp OracleWorld A) (next : A → OracleComp OracleWorld B) :
+    hashInputs first ⊆ hashInputs (first >>= next) := by
+  induction first using OracleComp.inductionOn with
+  | pure value => simp only [hashInputs_pure, Finset.empty_subset]
+  | query_bind input tail ih =>
+      intro row hrow
+      rw [hashInputs_query_bind, Finset.mem_union] at hrow
+      rw [bind_assoc, hashInputs_query_bind, Finset.mem_union]
+      rcases hrow with hhead | htail
+      · cases input <;> exact Or.inl hhead
+      · obtain ⟨answer, _, hrow⟩ := Finset.mem_biUnion.mp htail
+        exact Or.inr (Finset.mem_biUnion.mpr ⟨answer, Finset.mem_univ _, ih answer hrow⟩)
+
+theorem boundaryComputation_query_bind {Result : Type} (parameter : PublicParameter)
+    (input : OracleWorld.Domain) (next : OracleWorld.Range input → OracleComp OracleWorld Result) :
+    boundaryComputation parameter (liftM (OracleWorld.query input) >>= next) =
+      liftM (OracleWorld.query input) >>= fun answer =>
+        (fun result => (result.1, signingBoundaryTrace parameter input answer * result.2)) <$>
+          boundaryComputation parameter (next answer) := by
+  simp [boundaryComputation, QueryImpl.withTrace_apply]
+
+theorem fixedBoundaryRun_boundaryComputation {Result : Type} (parameter : PublicParameter)
+    (oracle : QueryImpl HashSpec Id) (computation : OracleComp OracleWorld Result) :
+    fixedBoundaryRun parameter oracle (boundaryComputation parameter computation) =
+      (fun result => (result, result.2)) <$> fixedBoundaryRun parameter oracle computation := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => rfl
+  | query_bind input next ih =>
+      rw [boundaryComputation_query_bind, fixedBoundaryRun_query_bind,
+        fixedBoundaryRun_query_bind, map_bind]
+      apply bind_congr
+      intro answer
+      simp only [fixedBoundaryRun_map, ih, Functor.map_map, Prod.map_apply, id_eq]
+
+theorem messageOnly_boundary {Result : Type} (parameter : PublicParameter)
+    (computation : OracleComp OracleWorld Result) (hmessage : MessageOnly parameter computation) :
+    MessageOnly parameter (boundaryComputation parameter computation) := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => exact messageOnly_pure parameter (value, 1)
+  | query_bind input next ih =>
+      rw [boundaryComputation_query_bind]
+      apply messageOnly_query_bind parameter input _
+      · cases input with
+        | inl _ => trivial
+        | inr input => exact hmessage input (mem_hashInputs_hash_bind input next)
+      · intro answer
+        exact messageOnly_map parameter _ _ (ih answer
+          (fun row hrow => hmessage row ((hashInputs_next_subset input next answer) hrow)))
+
+theorem messageOnly_publicSignAttempt (parameter : PublicParameter) (root : Digest) (message : Message) (randomness : Randomness) :
+    MessageOnly parameter (liftM (publicSignAttempt parameter root message randomness)) := by
+  simp only [publicSignAttempt, messageDigest, bind_assoc, pure_bind, liftM_bind]
+  apply messageOnly_query_bind parameter (.inr (tweakableHashInput parameter .message (messageDigestPayload root message randomness))) _
+  · exact ⟨_, rfl⟩
+  · intro answer
+    split <;> exact messageOnly_pure parameter _
+
+theorem messageOnly_publicDigestLoop (parameter : PublicParameter) (root : Digest) (message : Message) (attempts : Nat) :
+    MessageOnly parameter (publicDigestLoop parameter root message attempts) := by
+  induction attempts with
+  | zero => rw [publicDigestLoop]; exact messageOnly_pure parameter none
+  | succ attempts ih =>
+      rw [publicDigestLoop]
+      apply messageOnly_bind parameter _ _ (messageOnly_lift_prob parameter sampleRandomness)
+      intro randomness
+      apply messageOnly_bind parameter _ _ (messageOnly_publicSignAttempt parameter root message randomness)
+      intro attempt
+      cases attempt with
+      | none => exact ih
+      | some selected => exact messageOnly_pure parameter _
+
+noncomputable def publicSigningWork (parameter : PublicParameter) (root : Digest) (known : Labels)
+    (words : OtsReferenceWords) (selections : ReferenceFamily) (message : Message) :
+    OracleComp OracleWorld (PublicSigningRecord × Nat) := do
+  let selected ← boundaryComputation parameter (publicDigestLoop parameter root message digestAttemptLimit)
+  match selected.1 with
+  | none => pure (((none, none), selected.2), 0)
+  | some (randomness, index, leaves) =>
+      let plan := publicSignPlan known words selections randomness index leaves
+      pure (((plan.1, some (selectedFewTimeView index leaves)), selected.2 * (FreeMonoid.of none) ^ plan.2), plan.2)
+
+theorem publicSigningWork_messageOnly (parameter : PublicParameter) (root : Digest) (known : Labels)
+    (words : OtsReferenceWords) (selections : ReferenceFamily) (message : Message) :
+    MessageOnly parameter (publicSigningWork parameter root known words selections message) := by
+  rw [publicSigningWork]
+  apply messageOnly_bind parameter _ _ (messageOnly_boundary parameter _
+    (messageOnly_publicDigestLoop parameter root message digestAttemptLimit))
+  rintro ⟨selected, trace⟩
+  cases selected <;> exact messageOnly_pure parameter _
+
+theorem hashInputs_publicSigningWork (parameter : PublicParameter) (root : Digest) (known : Labels)
+    (words : OtsReferenceWords) (selections : ReferenceFamily) (message : Message) :
+    hashInputs (publicSigningWork parameter root known words selections message) =
+      hashInputs (publicDigestLoop parameter root message digestAttemptLimit) := by
+  rw [publicSigningWork, hashInputs_bind_pure_next, hashInputs_boundary]
+  rintro ⟨selected, trace⟩
+  cases selected <;> exact ⟨_, rfl⟩
+
+theorem hashInputs_publicSigningWork_subset_signWithView (key : SecretKey) (known : Labels)
+    (words : OtsReferenceWords) (selections : ReferenceFamily) (message : Message) :
+    hashInputs (publicSigningWork key.parameter key.root known words selections message) ⊆ hashInputs (signWithView key message) := by
+  rw [hashInputs_publicSigningWork, publicDigestLoop_eq, signWithView]
+  exact hashInputs_left_subset _ _
+
+def accountWork (memory : ExternalMemory) (cost : Nat) : ExternalMemory :=
+  { memory with hashCalls := memory.hashCalls + cost }
+
+theorem applyBoundary_pow_none (memory : ExternalMemory) (cost : Nat) :
+    applyBoundary memory ((FreeMonoid.of none : SigningBoundaryTrace) ^ cost) = accountWork memory cost := by
+  simp only [applyBoundary, SigningBoundaryTrace.messageCalls_pow_none, SigningBoundaryTrace.hashCalls_pow_none, List.foldl_nil]
+  rfl
+
+end SphincsSecurity.Concrete.ResidualByteFrontend
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/DirectQueryBudget.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/DirectQueryBudget.lean
new file mode 100644
index 000000000..b2629863f
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/DirectQueryBudget.lean
@@ -0,0 +1,67 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.RootCache
+import SphincsSecurity.Proof.Scheme.Secrets
+import SphincsSecurity.Proof.Reference.SigningTrace
+/-!
+# 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 : Message)
+    (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 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
+
+namespace Concrete
+
+end Concrete
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/FiniteHashWorld.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/FiniteHashWorld.lean
new file mode 100644
index 000000000..9d79d5f5b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/FiniteHashWorld.lean
@@ -0,0 +1,151 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Reference.FixedHashBoundary
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec OracleComp.DeferredSampling
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable local instance instSampleableTypeForallSubtypeHashInputMemFinsetHashOutput (inputs : Finset HashInput) : SampleableType (inputs → HashOutput) :=
+  SampleableType.ofFintype (inputs → HashOutput)
+
+noncomputable def sampleHashTable (inputs : Finset HashInput) : ProbComp (inputs → HashOutput) :=
+  $ᵗ (inputs → HashOutput)
+
+theorem evalDist_finiteHashTable_extract {α : Type} (inputs : Finset HashInput) (input : inputs)
+    (next : (inputs → HashOutput) → HashOutput → ProbComp α) :
+    𝒟[do let table ← ($ᵗ (inputs → HashOutput) : ProbComp _); next table (table input)] =
+      𝒟[do
+        let output ← ($ᵗ HashOutput : ProbComp _)
+        let table ← ($ᵗ (inputs → HashOutput) : ProbComp _)
+        next (Function.update table input output) output] := by
+  classical
+  have h := congrArg (fun distribution : SPMF (inputs → HashOutput) =>
+    distribution >>= fun table => 𝒟[next table (table input)])
+    (evalDist_uniformSample_bind_update (R := HashOutput) input)
+  simpa only [evalDist_bind, bind_assoc, evalDist_pure, pure_bind, Function.update_self] using h.symm
+
+noncomputable def hashInputs {α : Type} (computation : OracleComp OracleWorld α) : Finset HashInput := by
+  classical
+  induction computation using OracleComp.construct with
+  | pure _ => exact ∅
+  | query_bind input _ tail =>
+      exact (match input with | .inl _ => ∅ | .inr input => {input}) ∪ Finset.univ.biUnion tail
+
+@[simp] theorem hashInputs_pure {α : Type} (value : α) :
+    hashInputs (pure value) = ∅ := rfl
+
+theorem hashInputs_query_bind {α : Type} (input : OracleWorld.Domain)
+    (next : OracleWorld.Range input → OracleComp OracleWorld α) :
+    hashInputs (liftM (OracleWorld.query input) >>= next) =
+      (match input with | .inl _ => ∅ | .inr input => {input}) ∪
+        Finset.univ.biUnion (fun output => hashInputs (next output)) := by
+  simp only [hashInputs, OracleComp.construct_query_bind]
+  cases input <;> rfl
+
+attribute [local irreducible] hashInputs
+
+theorem hashInputs_next_subset {α : Type} (input : OracleWorld.Domain)
+    (next : OracleWorld.Range input → OracleComp OracleWorld α) (output : OracleWorld.Range input) :
+    hashInputs (next output) ⊆ hashInputs (liftM (OracleWorld.query input) >>= next) := by
+  intro row hrow
+  rw [hashInputs_query_bind, Finset.mem_union]
+  exact Or.inr (Finset.mem_biUnion.mpr ⟨output, Finset.mem_univ _, hrow⟩)
+
+theorem mem_hashInputs_hash_bind {α : Type} (input : HashInput)
+    (next : HashOutput → OracleComp OracleWorld α) :
+    input ∈ hashInputs (liftM (OracleWorld.query (.inr input)) >>= next) := by
+  rw [hashInputs_query_bind, Finset.mem_union]
+  exact Or.inl (Finset.mem_singleton_self _)
+
+noncomputable def finiteHashAnswer (cache : QueryCache HashSpec) (inputs : Finset HashInput)
+    (table : inputs → HashOutput) : QueryImpl HashSpec Id :=
+  fun input => (cache input).getD (if h : input ∈ inputs then table ⟨input, h⟩ else 0)
+
+theorem finiteHashAnswer_some (cache : QueryCache HashSpec) (inputs : Finset HashInput)
+    (table : inputs → HashOutput) (input : HashInput) (output : HashOutput) (h : cache input = some output) :
+    finiteHashAnswer cache inputs table input = output := by
+  simp only [finiteHashAnswer, h, Option.getD_some]
+
+theorem finiteHashAnswer_none (cache : QueryCache HashSpec) (inputs : Finset HashInput)
+    (table : inputs → HashOutput) (input : HashInput) (hin : input ∈ inputs) (h : cache input = none) :
+    finiteHashAnswer cache inputs table input = table ⟨input, hin⟩ := by
+  simp only [finiteHashAnswer, h, Option.getD_none, dif_pos hin]
+
+theorem finiteHashAnswer_cacheQuery (cache : QueryCache HashSpec) (inputs : Finset HashInput)
+    (table : inputs → HashOutput) (input : HashInput) (hin : input ∈ inputs)
+    (h : cache input = none) (output : HashOutput) :
+    finiteHashAnswer (cache.cacheQuery input output) inputs table =
+      finiteHashAnswer cache inputs (Function.update table ⟨input, hin⟩ output) := by
+  classical
+  funext row
+  by_cases heq : row = input
+  · subst row
+    simp [finiteHashAnswer, h, hin]
+  · by_cases hrow : row ∈ inputs
+    · have hne : (⟨row, hrow⟩ : inputs) ≠ ⟨input, hin⟩ := fun hsub => heq (congrArg Subtype.val hsub)
+      simp [finiteHashAnswer, QueryCache.cacheQuery, heq, hrow, hne]
+    · simp [finiteHashAnswer, QueryCache.cacheQuery, heq, hrow]
+
+theorem romRun_query_bind {α : Type} (input : OracleWorld.Domain)
+    (next : OracleWorld.Range input → OracleComp OracleWorld α) (cache : QueryCache HashSpec) :
+    (simulateQ romImpl (liftM (OracleWorld.query input) >>= next)).run' cache =
+      (romImpl input).run cache >>= fun result => (simulateQ romImpl (next result.1)).run' result.2 := by
+  rw [simulateQ_bind, simulateQ_spec_query, StateT.run'_eq, StateT.run_bind, map_bind]
+  rfl
+
+theorem evalDist_romRun_eq_finiteHash {α : Type} (computation : OracleComp OracleWorld α)
+    (inputs : Finset HashInput) (hinputs : hashInputs computation ⊆ inputs) (cache : QueryCache HashSpec) :
+    𝒟[(simulateQ romImpl computation).run' cache] =
+      𝒟[do
+        let table ← ($ᵗ (inputs → HashOutput) : ProbComp _)
+        simulateQ (fixedHashWorld (finiteHashAnswer cache inputs table)) computation] := by
+  classical
+  induction computation using OracleComp.inductionOn generalizing cache with
+  | pure value =>
+      simp only [simulateQ_pure, StateT.run'_eq, StateT.run_pure, map_pure]
+      exact (evalDist_bind_const_neverFails _ (by simp) (pure value)).symm
+  | query_bind input next ih =>
+      have hnext : ∀ output, hashInputs (next output) ⊆ inputs :=
+        fun output => (hashInputs_next_subset input next output).trans hinputs
+      rw [romRun_query_bind]
+      cases input with
+      | inl sample =>
+          change 𝒟[(liftM (unifSpec.query sample) : ProbComp _) >>= fun output =>
+            (simulateQ romImpl (next output)).run' cache] = _
+          trans 𝒟[do
+            let output ← (liftM (unifSpec.query sample) : ProbComp _)
+            let table ← ($ᵗ (inputs → HashOutput) : ProbComp _)
+            simulateQ (fixedHashWorld (finiteHashAnswer cache inputs table)) (next output)]
+          · exact evalDist_bind_congr_left _ _ _ (fun output => ih output (hnext output) cache)
+          · rw [evalDist_bind_comm]
+            apply evalDist_bind_congr_left
+            intro table
+            simp only [simulateQ_bind, simulateQ_spec_query, fixedHashWorld]
+            rfl
+      | inr input =>
+          have hin : input ∈ inputs := hinputs (mem_hashInputs_hash_bind input next)
+          rw [show romImpl (.inr input) = randomOracle (spec := HashSpec) input from rfl]
+          cases hcache : cache input with
+          | some output =>
+              rw [QueryImpl.withCaching_run_some _ hcache, pure_bind, ih output (hnext output) cache]
+              apply evalDist_bind_congr_left
+              intro table
+              simp only [simulateQ_bind, simulateQ_spec_query, fixedHashWorld,
+                finiteHashAnswer_some cache inputs table input output hcache, pure_bind]
+          | none =>
+              rw [QueryImpl.withCaching_run_none _ hcache, map_eq_bind_pure_comp]
+              simp only [Function.comp, bind_assoc, pure_bind]
+              trans 𝒟[do
+                let output ← ($ᵗ HashOutput : ProbComp _)
+                let table ← ($ᵗ (inputs → HashOutput) : ProbComp _)
+                simulateQ (fixedHashWorld (finiteHashAnswer (cache.cacheQuery input output) inputs table)) (next output)]
+              · exact evalDist_bind_congr_left _ _ _ (fun output => ih output (hnext output) _)
+              · simp_rw [finiteHashAnswer_cacheQuery cache inputs _ input hin hcache]
+                rw [← evalDist_finiteHashTable_extract inputs (⟨input, hin⟩ : inputs)
+                  (fun table output => simulateQ (fixedHashWorld (finiteHashAnswer cache inputs table)) (next output))]
+                apply evalDist_bind_congr_left
+                intro table
+                simp only [simulateQ_bind, simulateQ_spec_query, fixedHashWorld,
+                  finiteHashAnswer_none cache inputs table input hin hcache, pure_bind]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/FixedHashBoundary.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/FixedHashBoundary.lean
new file mode 100644
index 000000000..bfb053348
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/FixedHashBoundary.lean
@@ -0,0 +1,140 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.CanonicalSigningFrontier
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] boundaryEval sequenceFin chainWalk referenceEncodingSearch signDigestLoop
+
+noncomputable def fixedHashWorld (f : QueryImpl HashSpec Id) : QueryImpl OracleWorld ProbComp
+  | .inl input => liftM (unifSpec.query input)
+  | .inr input => pure (f input)
+
+noncomputable def fixedBoundaryRun {α : Type} (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (computation : OracleComp OracleWorld α) : ProbComp (α × SigningBoundaryTrace) :=
+  (simulateQ ((fixedHashWorld f).withTrace (signingBoundaryTrace parameter)) computation).run
+
+theorem fixedBoundaryRun_pure {α : Type} (parameter : PublicParameter) (f : QueryImpl HashSpec Id) (value : α) :
+    fixedBoundaryRun parameter f (pure value) = pure (value, 1) := rfl
+
+theorem fixedBoundaryRun_bind {α β : Type} (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (first : OracleComp OracleWorld α) (next : α → OracleComp OracleWorld β) :
+    fixedBoundaryRun parameter f (first >>= next) =
+      fixedBoundaryRun parameter f first >>= fun result =>
+        (fun final => (final.1, result.2 * final.2)) <$> fixedBoundaryRun parameter f (next result.1) := by
+  simp only [fixedBoundaryRun, simulateQ_bind, WriterT.run_bind]
+
+theorem fixedBoundaryRun_map {α β : Type} (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (computation : OracleComp OracleWorld α) (g : α → β) :
+    fixedBoundaryRun parameter f (g <$> computation) =
+      (Prod.map g id) <$> fixedBoundaryRun parameter f computation := by
+  simp only [fixedBoundaryRun, simulateQ_map, WriterT.run_map]
+  rfl
+
+theorem fixedBoundaryRun_forget {α : Type} (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (computation : OracleComp OracleWorld α) :
+    Prod.fst <$> fixedBoundaryRun parameter f computation = simulateQ (fixedHashWorld f) computation :=
+  QueryImpl.fst_map_run_withTrace (fixedHashWorld f) (signingBoundaryTrace parameter) computation
+
+theorem fixedBoundaryRun_lift_hash {α : Type} (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (computation : OracleComp HashSpec α) :
+    fixedBoundaryRun parameter f (liftM computation) = pure (boundaryEval parameter f computation) := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => rw [liftM_pure, fixedBoundaryRun_pure, boundaryEval_pure]
+  | query_bind input next ih =>
+      rw [liftM_bind, fixedBoundaryRun_bind, boundaryEval_bind, boundaryEval_hash_query]
+      have hquery : fixedBoundaryRun parameter f
+          (liftM (liftM (HashSpec.query input) : OracleComp HashSpec HashOutput)) =
+          pure (f input, signingBoundaryTrace parameter (.inr input) (f input)) := by
+        change (simulateQ ((fixedHashWorld f).withTrace (signingBoundaryTrace parameter))
+          (liftM (OracleWorld.query (.inr input)))).run = _
+        rw [simulateQ_spec_query]
+        rfl
+      rw [hquery, pure_bind, ih, map_pure]
+      rfl
+
+def publicSignAttempt (parameter : PublicParameter) (root : Digest) (message : Message) (randomness : Randomness) :
+    OracleComp HashSpec (Option (Index × (IndexGroup → FtsLeaf))) := do
+  let digest ← messageDigest parameter root message randomness
+  if Admissible digest then pure (some (digestIndex digest, digestLeaves digest)) else pure none
+
+noncomputable def publicDigestLoop (parameter : PublicParameter) (root : Digest) (message : Message) :
+    Nat → OracleComp OracleWorld (Option (Randomness × Index × (IndexGroup → FtsLeaf)))
+  | 0 => pure none
+  | attempts + 1 => do
+      let randomness ← liftM sampleRandomness
+      let attempt ← liftM (publicSignAttempt parameter root message randomness)
+      match attempt with
+      | none => publicDigestLoop parameter root message attempts
+      | some (index, leaves) => pure (some (randomness, index, leaves))
+
+theorem publicDigestLoop_eq (key : SecretKey) (message : Message) (attempts : Nat) :
+    publicDigestLoop key.parameter key.root message attempts = signDigestLoop attempts key message := by
+  induction attempts with
+  | zero => rw [publicDigestLoop, signDigestLoop]
+  | succ attempts ih =>
+      rw [publicDigestLoop, signDigestLoop]
+      apply bind_congr
+      intro randomness
+      have hattempt : publicSignAttempt key.parameter key.root message randomness =
+          (signAttempt key message randomness : OracleComp HashSpec _) := rfl
+      rw [hattempt]
+      apply bind_congr
+      intro attempt
+      cases attempt with
+      | none => exact ih
+      | some selected => rfl
+
+noncomputable def frontierSigningRecord (parameter : PublicParameter) (root : Digest) (f : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords)
+    (frontier : OtsFrontierValues) (message : Message) :
+    ProbComp ((Option Signature × Option FewTimeView) × SigningBoundaryTrace) := do
+  let selected ← fixedBoundaryRun parameter f (publicDigestLoop parameter root message digestAttemptLimit)
+  match selected.1 with
+  | none => pure ((none, none), selected.2)
+  | some (randomness, index, leaves) =>
+      let result := frontierSignAfterDigest parameter f ftsSecret words frontier randomness index leaves
+      pure ((result.1, some (selectedFewTimeView index leaves)), selected.2 * (FreeMonoid.of none) ^ result.2)
+
+theorem fixedBoundaryRun_signWithView_frontier (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (hfrontier : IsSigningFrontier key f words frontier)
+    (hwords : ∀ index lay, FrontierReferenceWord key.parameter f key.ftsSecret words frontier index lay)
+    (message : Message) :
+    fixedBoundaryRun key.parameter f (signWithView key message) =
+      frontierSigningRecord key.parameter key.root f key.ftsSecret words frontier message := by
+  rw [signWithView, fixedBoundaryRun_bind, frontierSigningRecord, publicDigestLoop_eq]
+  apply bind_congr
+  rintro ⟨selected, trace⟩
+  cases selected with
+  | none => simp only [fixedBoundaryRun_pure, map_pure, mul_one]
+  | some selected =>
+      obtain ⟨randomness, index, leaves⟩ := selected
+      rw [fixedBoundaryRun_bind, fixedBoundaryRun_lift_hash,
+        boundaryEval_signAfterDigest_frontier key f words frontier hfrontier randomness index leaves (hwords index)]
+      simp only [pure_bind, fixedBoundaryRun_pure, map_pure, mul_one]
+
+theorem fixedBoundaryRun_signWithView_canonical (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (dummy : OtsReferenceWords) (message : Message) :
+    fixedBoundaryRun key.parameter f (signWithView key message) =
+      frontierSigningRecord key.parameter key.root f key.ftsSecret (canonicalReferenceWords key f dummy)
+        (canonicalFrontierValues key f (canonicalReferenceWords key f dummy)) message :=
+  fixedBoundaryRun_signWithView_frontier key f _ _ (isSigningFrontier_canonical key f _)
+    (frontierReferenceWord_canonical key f dummy) message
+
+noncomputable def frontierSigningRun (parameter : PublicParameter) (root : Digest) (f : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords)
+    (frontier : OtsFrontierValues) (message : Message) : ProbComp (Option Signature × SigningBoundaryTrace) :=
+  (Prod.map Prod.fst id) <$> frontierSigningRecord parameter root f ftsSecret words frontier message
+
+theorem fixedBoundaryRun_sign_frontier (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (hfrontier : IsSigningFrontier key f words frontier)
+    (hwords : ∀ index lay, FrontierReferenceWord key.parameter f key.ftsSecret words frontier index lay)
+    (message : Message) :
+    fixedBoundaryRun key.parameter f (sign key message) =
+      frontierSigningRun key.parameter key.root f key.ftsSecret words frontier message := by
+  rw [← signWithView_fst, fixedBoundaryRun_map, fixedBoundaryRun_signWithView_frontier key f words frontier hfrontier hwords]
+  rfl
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/QueryAllocation.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/QueryAllocation.lean
new file mode 100644
index 000000000..24b6e0a5e
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/QueryAllocation.lean
@@ -0,0 +1,99 @@
+import SphincsSecurity.Proof.Base.QueryCapAccounting
+namespace SphincsSecurity.QueryCap
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+variable {Index : Type} {spec : OracleSpec Index} {Result : Type}
+
+noncomputable def recorded (computation : OracleComp spec Result) : OracleComp spec (Result × List Index) :=
+  OracleComp.construct (fun result => pure (result, []))
+    (fun input _ next => do
+      let answer ← liftM (spec.query input)
+      let result ← next answer
+      pure (result.1, input :: result.2)) computation
+
+theorem recorded_pure (result : Result) : recorded (pure result : OracleComp spec Result) = pure (result, []) := rfl
+
+theorem recorded_query_bind (input : spec.Domain) (next : spec.Range input → OracleComp spec Result) :
+    recorded (liftM (spec.query input) >>= next) = (do
+      let answer ← liftM (spec.query input)
+      let result ← recorded (next answer)
+      pure (result.1, input :: result.2)) := rfl
+
+def calls (selected : Index → Prop) [DecidablePred selected] (inputs : List Index) : Nat :=
+  inputs.countP (fun input => decide (selected input))
+
+theorem calls_nil (selected : Index → Prop) [DecidablePred selected] : calls selected [] = 0 := rfl
+
+theorem calls_cons (selected : Index → Prop) [DecidablePred selected] (input : Index) (inputs : List Index) :
+    calls selected (input :: inputs) = (if selected input then 1 else 0) + calls selected inputs := by
+  simp [calls, List.countP_cons, Nat.add_comm]
+
+theorem recorded_counted (selected : Index → Prop) [DecidablePred selected] (computation : OracleComp spec Result) :
+    (fun result => (result.1, calls selected result.2)) <$> recorded computation = counted selected computation := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => simp only [recorded_pure, counted_pure, map_pure, calls_nil]
+  | query_bind input next ih =>
+      simp only [recorded_query_bind, counted_query_bind, map_bind, map_pure, calls_cons]
+      congr 1
+      funext answer
+      rw [← ih answer]
+      simp only [bind_map_left]
+
+theorem recorded_forget (computation : OracleComp spec Result) : Prod.fst <$> recorded computation = computation := by
+  have h := congrArg (Functor.map Prod.fst) (recorded_counted (fun _ => True) computation)
+  simpa only [Functor.map_map, counted_forget] using h
+
+theorem calls_sum_le {Address : Type} (addresses : Finset Address)
+    (selected : Address → Index → Prop) [∀ address, DecidablePred (selected address)]
+    (total : Index → Prop) [DecidablePred total]
+    (hdisjoint : ∀ input, (∑ address ∈ addresses, if selected address input then 1 else 0) ≤ if total input then 1 else 0)
+    (inputs : List Index) : (∑ address ∈ addresses, calls (selected address) inputs) ≤ calls total inputs := by
+  induction inputs with
+  | nil => simp only [calls_nil, Finset.sum_const_zero, le_refl]
+  | cons input inputs ih =>
+      simp only [calls_cons, Finset.sum_add_distrib]
+      exact Nat.add_le_add (hdisjoint input) ih
+
+theorem recorded_calls_le (selected : Index → Prop) [DecidablePred selected]
+    (computation : OracleComp spec Result) (cost : Result → Nat)
+    (hcounted : ∀ result ∈ support (counted selected computation), result.2 ≤ cost result.1)
+    (result : Result × List Index) (hresult : result ∈ support (recorded computation)) :
+    calls selected result.2 ≤ cost result.1 := by
+  apply hcounted (result.1, calls selected result.2)
+  rw [← recorded_counted, support_map]
+  exact ⟨result, hresult, rfl⟩
+
+theorem counted_query (selected : Index → Prop) [DecidablePred selected] (input : spec.Domain) :
+    counted selected (liftM (spec.query input) : OracleComp spec _) =
+      (fun answer => (answer, if selected input then 1 else 0)) <$> (liftM (spec.query input) : OracleComp spec _) := by
+  have h := counted_query_bind selected input (fun answer => pure answer)
+  simpa only [bind_pure, counted_pure, pure_bind, Nat.add_zero, bind_pure_comp, map_pure] using h
+
+theorem simulate_counted {Target : Type} {target : OracleSpec Target} {m : Type → Type} [Monad m] [LawfulMonad m]
+    (selected : Index → Prop) [DecidablePred selected] (selectedTarget : Target → Prop) [DecidablePred selectedTarget]
+    (handler : QueryImpl spec (OracleComp target)) (targetImpl : QueryImpl target m) (sourceImpl : QueryImpl spec m)
+    (hhandler : ∀ input, simulateQ targetImpl (counted selectedTarget (handler input)) =
+      (fun answer => (answer, if selected input then 1 else 0)) <$> sourceImpl input)
+    (computation : OracleComp spec Result) :
+    simulateQ targetImpl (counted selectedTarget (simulateQ handler computation)) =
+      simulateQ sourceImpl (counted selected computation) := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => simp only [simulateQ_pure, counted_pure]
+  | query_bind input next ih =>
+      simp only [simulateQ_bind, simulateQ_spec_query, counted_bind, counted_query, simulateQ_pure,
+        hhandler, bind_map_left, ih]
+
+theorem simulate_oracle_mem_support {Target : Type} {target : OracleSpec Target}
+    (handler : QueryImpl spec (OracleComp target)) (computation : OracleComp spec Result)
+    (result : Result) (hresult : result ∈ support (simulateQ handler computation)) : result ∈ support computation := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => simpa only [simulateQ_pure, mem_support_pure_iff] using hresult
+  | query_bind input next ih =>
+      rw [simulateQ_bind, simulateQ_spec_query, mem_support_bind_iff] at hresult
+      obtain ⟨answer, _, hresult⟩ := hresult
+      rw [mem_support_bind_iff]
+      exact ⟨answer, by simp only [support_query, Set.mem_univ], ih answer hresult⟩
+
+end SphincsSecurity.QueryCap
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/QueryBound.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/QueryBound.lean
new file mode 100644
index 000000000..68ef54ca0
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/QueryBound.lean
@@ -0,0 +1,40 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Statement
+
+/-!
+# 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)
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/QueryClassAllocation.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/QueryClassAllocation.lean
new file mode 100644
index 000000000..cbb541b32
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/QueryClassAllocation.lean
@@ -0,0 +1,91 @@
+import SphincsSecurity.Proof.Reference.BoundaryChargePartition
+import SphincsSecurity.Proof.Ots.OtsPrefixAllocation
+namespace SphincsSecurity.Concrete.QueryClass
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+def EncodingHash (parameter : PublicParameter) : OracleWorld.Domain → Prop
+  | .inl _ => False
+  | .inr input => ∃ position, AtEncodingPosition parameter input position
+
+def OtherHash (parameter : PublicParameter) (words : OtsReferenceWords) (input : OracleWorld.Domain) : Prop :=
+  CausalFrontierProgram.NonmessageHash parameter input ∧ ¬EncodingHash parameter input ∧
+    ∀ address, ¬(OtsPrefix.atAddress parameter words address).Selects input
+
+noncomputable instance (parameter : PublicParameter) : DecidablePred (EncodingHash parameter) := Classical.decPred _
+noncomputable instance (parameter : PublicParameter) (words : OtsReferenceWords) : DecidablePred (OtherHash parameter words) :=
+  Classical.decPred _
+
+theorem encoding_nonmessage (parameter : PublicParameter) (input : OracleWorld.Domain) (hencoding : EncodingHash parameter input) :
+    CausalFrontierProgram.NonmessageHash parameter input := by
+  cases input with
+  | inl input => exact False.elim hencoding
+  | inr input =>
+      obtain ⟨position, payload, hinput⟩ := hencoding
+      rintro ⟨message, hmessage⟩
+      have hdomain := (tweakableHashInput_injective parameter (by trivial) (by trivial) (hinput.symm.trans hmessage.symm)).1
+      simp only [EncodingPosition.domain, reduceCtorEq] at hdomain
+
+theorem prefix_nonmessage (segment : OtsPrefix) (input : OracleWorld.Domain) (hprefix : segment.Selects input) :
+    CausalFrontierProgram.NonmessageHash segment.parameter input := by
+  cases input with
+  | inl input => exact False.elim hprefix
+  | inr input =>
+      obtain ⟨query, hquery⟩ := Option.ne_none_iff_exists'.mp hprefix
+      have hinput := (segment.parse_some_iff input query).mp hquery
+      rintro ⟨message, hmessage⟩
+      have hdomain := (tweakableHashInput_injective segment.parameter (by trivial) (by trivial)
+        (hinput.symm.trans hmessage.symm)).1
+      simp only [reduceCtorEq] at hdomain
+
+theorem prefix_not_encoding (segment : OtsPrefix) (input : OracleWorld.Domain) (hprefix : segment.Selects input) :
+    ¬EncodingHash segment.parameter input := by
+  cases input with
+  | inl input => exact False.elim hprefix
+  | inr input =>
+      obtain ⟨query, hquery⟩ := Option.ne_none_iff_exists'.mp hprefix
+      have hinput := (segment.parse_some_iff input query).mp hquery
+      rintro ⟨position, hencoding⟩
+      exact hencoding.not_atPosition (.chain segment.lay segment.tree segment.leaf segment.chainIdx (segment.step query.1))
+        ⟨digestBytes query.2, hinput⟩
+
+theorem allocation_step (parameter : PublicParameter) (words : OtsReferenceWords) (input : OracleWorld.Domain) :
+    (∑ address : OtsPrefix.ChainAddress, if (OtsPrefix.atAddress parameter words address).Selects input then 1 else 0) +
+        (if EncodingHash parameter input then 1 else 0) + (if OtherHash parameter words input then 1 else 0) =
+      if CausalFrontierProgram.NonmessageHash parameter input then 1 else 0 := by
+  classical
+  by_cases hprefix : ∃ address, (OtsPrefix.atAddress parameter words address).Selects input
+  · obtain ⟨address, haddress⟩ := hprefix
+    have hsum : (∑ other : OtsPrefix.ChainAddress, if (OtsPrefix.atAddress parameter words other).Selects input then 1 else 0) = 1 := by
+      rw [Finset.sum_eq_single address]
+      · exact if_pos haddress
+      · intro other _ hne
+        exact if_neg (fun hother => hne (OtsPrefix.atAddress_selects_unique parameter words other address input hother haddress))
+      · simp
+    have hn := prefix_nonmessage _ input haddress
+    have he := prefix_not_encoding _ input haddress
+    have ho : ¬OtherHash parameter words input := fun h => h.2.2 address haddress
+    simp only [hsum, if_neg he, if_neg ho, if_pos hn, Nat.add_zero]
+  · have hnone : ∀ address, ¬(OtsPrefix.atAddress parameter words address).Selects input := by simpa using hprefix
+    have hsum : (∑ address : OtsPrefix.ChainAddress, if (OtsPrefix.atAddress parameter words address).Selects input then 1 else 0) = 0 := by
+      simp only [hnone, if_false, Finset.sum_const_zero]
+    rw [hsum, Nat.zero_add]
+    by_cases he : EncodingHash parameter input
+    · have hn := encoding_nonmessage parameter input he
+      simp only [he, hn, OtherHash, not_true_eq_false, and_false, false_and, if_true, if_false, Nat.add_zero]
+    · by_cases hn : CausalFrontierProgram.NonmessageHash parameter input <;>
+        simp [he, hn, OtherHash, hnone]
+
+theorem allocation_calls (parameter : PublicParameter) (words : OtsReferenceWords) (inputs : List OracleWorld.Domain) :
+    (∑ address : OtsPrefix.ChainAddress, QueryCap.calls (OtsPrefix.atAddress parameter words address).Selects inputs) +
+        QueryCap.calls (EncodingHash parameter) inputs + QueryCap.calls (OtherHash parameter words) inputs =
+      QueryCap.calls (CausalFrontierProgram.NonmessageHash parameter) inputs := by
+  induction inputs with
+  | nil => simp only [QueryCap.calls_nil, Finset.sum_const_zero, Nat.add_zero]
+  | cons input inputs ih =>
+      simp only [QueryCap.calls_cons, Finset.sum_add_distrib]
+      have h := allocation_step parameter words input
+      omega
+
+end SphincsSecurity.Concrete.QueryClass
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceAuxiliarySigning.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceAuxiliarySigning.lean
new file mode 100644
index 000000000..f4228189b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceAuxiliarySigning.lean
@@ -0,0 +1,102 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.PublicSigningRecord
+import SphincsSecurity.Proof.Reference.ReferenceResidualSeeds
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+theorem referenceAuxiliarySample_select (inputs : Finset HashInput) (auxiliary : ReferenceAuxiliary inputs)
+    (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support) (position : EncodingPosition) :
+    FirstSuccessTable.select decodeEncodingOutput (fun counter => auxiliary.rows (position, counter)) =
+      auxiliary.selections position := by
+  rw [referenceAuxiliarySample, PMF.mem_support_bind_iff] at hauxiliary
+  obtain ⟨selections, hselections, hauxiliary⟩ := hauxiliary
+  rw [PMF.mem_support_bind_iff] at hauxiliary
+  obtain ⟨rows, hrows, hauxiliary⟩ := hauxiliary
+  rw [PMF.mem_support_map_iff] at hauxiliary
+  obtain ⟨seed, _, rfl⟩ := hauxiliary
+  have hselected : FirstSuccessFamily.select decodeEncodingOutput encodingAttemptLimit rows = selections := by
+    by_contra hne
+    have hmass := FirstSuccessFamily.selected_mul_afterSelect decodeEncodingOutput encodingAttemptLimit
+      decodeEncodingOutput_invalid_nonempty selections rows
+    rw [if_neg hne] at hmass
+    exact mul_ne_zero ((PMF.mem_support_iff _ _).mp hselections) ((PMF.mem_support_iff _ _).mp hrows) hmass
+  exact congrFun hselected position
+
+theorem referenceTableSelection_auxiliary (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary inputs) (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support) :
+    referenceTableSelection key (programmedHash key.parameter key.otsSecret key.ftsSecret labels
+      (finiteHashAnswer ∅ inputs (canonicalReferenceResidual key.parameter inputs hencoding labels auxiliary.rows auxiliary.seed))) =
+        auxiliary.selections := by
+  funext position
+  rw [referenceTableSelection_programmedHash key inputs hencoding]
+  simp only [canonicalReferenceResidual, UniformTableSplit.overwrite_embed]
+  exact referenceAuxiliarySample_select inputs auxiliary hauxiliary position
+
+theorem referenceAuxiliary_words (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary inputs) (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support)
+    (dummy : OtsReferenceWords) :
+    referenceFamilyWords auxiliary.selections dummy = canonicalReferenceWords key
+      (programmedHash key.parameter key.otsSecret key.ftsSecret labels
+        (finiteHashAnswer ∅ inputs (canonicalReferenceResidual key.parameter inputs hencoding labels auxiliary.rows auxiliary.seed))) dummy := by
+  rw [← referenceTableSelection_auxiliary key inputs hencoding labels auxiliary hauxiliary, referenceFamilyWords_selected]
+
+theorem decodePosition_message (parameter : PublicParameter) (payload : HashInput) :
+    decodePosition parameter (tweakableHashInput parameter .message payload) = none := by
+  apply (decodePosition_none_iff parameter _).mpr
+  rintro position ⟨other, heq⟩
+  have hdomain := (tweakableHashInput_injective parameter (by trivial) position.domain_inRange heq).1
+  cases position <;> simp [Position.domain] at hdomain
+
+theorem frontierSigningRecord_auxiliary_public (key : SecretKey) (root : Digest) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary inputs) (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support)
+    (dummy : OtsReferenceWords) (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels)
+    (hagrees : PublicAgreement (referenceFamilyWords auxiliary.selections dummy) disclosed known
+      (CanonicalCoordinate.value key.otsSecret key.ftsSecret labels)) (message : Message) :
+    frontierSigningRecord key.parameter root
+        (programmedHash key.parameter key.otsSecret key.ftsSecret labels
+          (finiteHashAnswer ∅ inputs (canonicalReferenceResidual key.parameter inputs hencoding labels auxiliary.rows auxiliary.seed)))
+        key.ftsSecret (referenceFamilyWords auxiliary.selections dummy)
+        (canonicalGraphFrontier key.otsSecret labels (referenceFamilyWords auxiliary.selections dummy)) message =
+      completePublicSigningRecord key.ftsSecret <$>
+        publicSigningRecord key.parameter root
+          (finiteHashAnswer ∅ inputs (knownReferenceResidual key.parameter inputs hencoding known auxiliary.rows auxiliary.seed))
+          known (referenceFamilyWords auxiliary.selections dummy) auxiliary.selections message := by
+  have h := frontierSigningRecord_eq_public key root
+    (programmedHash key.parameter key.otsSecret key.ftsSecret labels
+      (finiteHashAnswer ∅ inputs (canonicalReferenceResidual key.parameter inputs hencoding labels auxiliary.rows auxiliary.seed)))
+    (finiteHashAnswer ∅ inputs (knownReferenceResidual key.parameter inputs hencoding known auxiliary.rows auxiliary.seed))
+    (referenceFamilyWords auxiliary.selections dummy) disclosed known
+    (by simpa only [canonicalGraphLabels_programmedHash] using hagrees) message
+    (fun randomness => programmedReferenceResidual_outside key.parameter inputs hencoding _ disclosed known
+      key.otsSecret key.ftsSecret labels hagrees auxiliary.rows auxiliary.seed _
+      (decodePosition_message key.parameter (messageDigestPayload root message randomness)))
+  simpa only [canonicalGraphLabels_programmedHash,
+    referenceTableSelection_auxiliary key inputs hencoding labels auxiliary hauxiliary] using h
+
+theorem fixedBoundaryRun_signWithView_auxiliary_public (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary inputs) (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support)
+    (dummy : OtsReferenceWords) (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels)
+    (hagrees : PublicAgreement (referenceFamilyWords auxiliary.selections dummy) disclosed known
+      (CanonicalCoordinate.value key.otsSecret key.ftsSecret labels)) (message : Message) :
+    fixedBoundaryRun key.parameter
+        (programmedHash key.parameter key.otsSecret key.ftsSecret labels
+          (finiteHashAnswer ∅ inputs (canonicalReferenceResidual key.parameter inputs hencoding labels auxiliary.rows auxiliary.seed)))
+        (signWithView key message) =
+      completePublicSigningRecord key.ftsSecret <$>
+        publicSigningRecord key.parameter key.root
+          (finiteHashAnswer ∅ inputs (knownReferenceResidual key.parameter inputs hencoding known auxiliary.rows auxiliary.seed))
+          known (referenceFamilyWords auxiliary.selections dummy) auxiliary.selections message := by
+  rw [fixedBoundaryRun_signWithView_canonical _ _ dummy,
+    ← canonicalGraphLabels_frontier key.parameter key.otsSecret key.ftsSecret _ _ key.root,
+    canonicalGraphLabels_programmedHash, ← referenceAuxiliary_words key inputs hencoding labels auxiliary hauxiliary dummy]
+  exact frontierSigningRecord_auxiliary_public key key.root inputs hencoding labels auxiliary hauxiliary dummy disclosed known hagrees message
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceCertificateCoverage.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceCertificateCoverage.lean
new file mode 100644
index 000000000..1e7da8b47
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceCertificateCoverage.lean
@@ -0,0 +1,231 @@
+import SphincsSecurity.Proof.Reference.ReferenceCertificateTrace
+import SphincsSecurity.Proof.Fts.OriginalProposalPrefixBound
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec OtsContactTrace
+open RetainedResidual (signingInput)
+open FtsProbeSimulation (messageAnswers)
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphLabels canonicalGraphInputs canonicalEncodingInputs canonicalGraphGameInputs
+  frontierRoot honestNode
+
+theorem eligibleSigningViews_eq_of_cache_agree (key : SecretKey) (before after : QueryCache HashSpec)
+    (log : QueryLog SigningSpec) (payload : HashInput)
+    (hlog : ∀ message signature, (⟨message, some signature⟩ : SigningEntry) ∈ log →
+      before (signingInput key message signature) = after (signingInput key message signature)) :
+    eligibleSigningViews (messageAnswers key.parameter before) key.root payload log =
+      eligibleSigningViews (messageAnswers key.parameter after) key.root payload log := by
+  funext slot
+  change eligibleSigningView? _ _ _ (log.get slot) = eligibleSigningView? _ _ _ (log.get slot)
+  have hentry := List.get_mem log slot
+  generalize he : log.get slot = entry at hentry ⊢
+  rcases entry with ⟨message, response⟩
+  cases response with
+  | none => simp [eligibleSigningView?]
+  | some signature =>
+      simp only [eligibleSigningView?, observedSigningView?, Option.bind_eq_bind', Option.bind_some]
+      change (if messageDigestPayload key.root message signature.randomness = payload then none
+        else before (signingInput key message signature) >>= fun answer => pure (hashOutputFewTimeView answer)) = _
+      rw [hlog message signature hentry]
+      rfl
+
+theorem recordedCache_agrees (f : QueryImpl HashSpec Id) (trace : Trace) : (recordedCache f trace).AgreesWithFn f := by
+  intro input output houtput
+  by_cases hm : (input, f input) ∈ trace.toList
+  · simpa only [recordedCache, if_pos hm, Option.some.injEq] using houtput
+  · simp only [recordedCache, if_neg hm] at houtput
+    cases houtput
+
+theorem boundaryEval_verify_message (key : SecretKey) (f : QueryImpl HashSpec Id) (forgery : Forgery) :
+    (signingInput key forgery.message forgery.signature, f (signingInput key forgery.message forgery.signature)) ∈
+      (boundaryEval key.parameter f (verify ⟨key.root, key.parameter⟩ forgery.message forgery.signature)).2.messageCalls := by
+  rw [verify, boundaryEval_bind, SigningBoundaryTrace.messageCalls_mul, List.mem_append]
+  apply Or.inl
+  have hquery : boundaryEval key.parameter f
+      (oracleHash (signingInput key forgery.message forgery.signature) : OracleComp HashSpec HashOutput) =
+      (f (signingInput key forgery.message forgery.signature), signingBoundaryTrace key.parameter
+        (.inr (signingInput key forgery.message forgery.signature)) (f (signingInput key forgery.message forgery.signature))) := rfl
+  rw [messageDigest, boundaryEval_bind]
+  change _ ∈ ((boundaryEval key.parameter f
+    (oracleHash (signingInput key forgery.message forgery.signature) : OracleComp HashSpec HashOutput)).2 * 1).messageCalls
+  rw [hquery, mul_one]
+  change (signingInput key forgery.message forgery.signature, f (signingInput key forgery.message forgery.signature)) ∈
+    (signingBoundaryTrace key.parameter (.inr (signingInput key forgery.message forgery.signature))
+      (f (signingInput key forgery.message forgery.signature))).messageCalls
+  rw [signingBoundaryTrace, if_pos (show FtsProbeSimulation.MessageHashInput key.parameter
+    (signingInput key forgery.message forgery.signature) from ⟨_, rfl⟩)]
+  exact List.mem_singleton_self _
+
+theorem certificate_to_message_record (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (before : (Forgery × QueryLog SigningSpec) × SigningBoundaryTrace) (trace : Trace) (required : Finset FtsTree)
+    (horigin : ∀ message signature, (⟨message, some signature⟩ : SigningEntry) ∈ before.1.2 →
+      ReferenceSigningWitness.SignatureOrigin key f message signature before.2)
+    (htrace : RetainedResidual.TraceValid key.parameter f (completeCertificateRest key f before).2)
+    (hcertificate : TargetCertificateAt key required (ReferenceFtsCoverage.transcriptCache f before.2 trace, before.1.2)
+      (signingInput key before.1.1.message before.1.1.signature)) :
+    TargetCertificateAt key required (hashRowsCache (completeCertificateRest key f before).2.messageCalls, before.1.2)
+      (signingInput key before.1.1.message before.1.1.signature) := by
+  have hrows : ∀ row ∈ (completeCertificateRest key f before).2.messageCalls, row.2 = f row.1 :=
+    fun row hr => (htrace row hr).2
+  have hsign (message : Message) (signature : Signature) (hentry : (⟨message, some signature⟩ : SigningEntry) ∈ before.1.2) :
+      hashRowsCache (completeCertificateRest key f before).2.messageCalls (signingInput key message signature) =
+        some (f (signingInput key message signature)) := by
+    apply hashRowsCache_lookup _ f hrows
+    rw [completeCertificateRest, SigningBoundaryTrace.messageCalls_mul, List.mem_append]
+    exact Or.inl (horigin message signature hentry).1
+  have htarget : hashRowsCache (completeCertificateRest key f before).2.messageCalls
+      (signingInput key before.1.1.message before.1.1.signature) = some (f (signingInput key before.1.1.message before.1.1.signature)) := by
+    apply hashRowsCache_lookup _ f hrows
+    rw [completeCertificateRest, SigningBoundaryTrace.messageCalls_mul, List.mem_append]
+    exact Or.inr (boundaryEval_verify_message key f before.1.1)
+  obtain ⟨output, houtput, hm, ha, hcovered⟩ := hcertificate
+  have hf : f (signingInput key before.1.1.message before.1.1.signature) = output :=
+    recordedCache_agrees f _ houtput
+  refine ⟨output, htarget.trans (congrArg some hf), hm, ha, ?_⟩
+  have hviews := eligibleSigningViews_eq_of_cache_agree key
+    (ReferenceFtsCoverage.transcriptCache f before.2 trace) (hashRowsCache (completeCertificateRest key f before).2.messageCalls)
+    before.1.2 (payloadOf (signingInput key before.1.1.message before.1.1.signature)) (fun message signature hentry =>
+      (ReferenceFtsCoverage.cache_signing (horigin message signature hentry) trace).trans (hsign message signature hentry).symm)
+  simpa only [TargetCoveredOn, ← hviews] using hcovered
+
+theorem referenceForgeryRest_traceValid_atRoot (key : SecretKey) (f : QueryImpl HashSpec Id) (root : Digest)
+    (hroot : root = (ReferenceVerifierWitness.rootedKey key f).root)
+    (dummy : OtsReferenceWords) (adversary : Adversary) (before : AdversaryTrace)
+    (hb : before ∈ support (referenceForgeryRest key f (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f)
+      (referenceTableSelection key f) dummy adversary)) :
+    RetainedResidual.TraceValid key.parameter f (completeCertificateRest { key with root := root } f before.1).2 := by
+  have hrecord : ({ key with root := root },
+      (completeCertificateRest { key with root := root } f before.1).1,
+      (completeCertificateRest { key with root := root } f before.1).2) ∈ support
+      ((fun before : AdversaryTrace =>
+        let result := completeCertificateRest ({ key with root := root } : SecretKey) f before.1
+        (({ key with root := root } : SecretKey), result.1, result.2)) <$>
+        referenceForgeryRest key f (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f)
+          (referenceTableSelection key f) dummy adversary) := by
+    rw [support_map]
+    exact ⟨before, hb, rfl⟩
+  rw [referenceForgeryRest_certificateRecord_atRoot key f root hroot dummy adversary, support_map] at hrecord
+  obtain ⟨result, hr, heq⟩ := hrecord
+  have heq' : result = completeCertificateRest { key with root := root } f before.1 := congrArg Prod.snd heq
+  rw [heq'] at hr
+  apply RetainedResidual.fixedBoundaryRun_traceValid key.parameter f _ _
+  simpa only [mem_support_iff, probOutput_def] using hr
+
+theorem referenceForgeryRest_origin_atRoot (key : SecretKey) (f : QueryImpl HashSpec Id) (root : Digest)
+    (hroot : root = (ReferenceVerifierWitness.rootedKey key f).root)
+    (dummy : OtsReferenceWords) (adversary : Adversary) (before : AdversaryTrace)
+    (hb : before ∈ support (referenceForgeryRest key f (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f)
+      (referenceTableSelection key f) dummy adversary))
+    (message : Message) (signature : Signature) (hentry : (⟨message, some signature⟩ : SigningEntry) ∈ before.1.1.2) :
+    ReferenceSigningWitness.SignatureOrigin { key with root := root } f message signature before.1.2 := by
+  rw [referenceForgeryRest, ReferenceVerifierWitness.source_root, ← hroot] at hb
+  have hw : referenceFamilyWords (referenceTableSelection key f) dummy =
+      canonicalReferenceWords ({ key with root := root } : SecretKey) f dummy := by
+    rw [referenceFamilyWords_selected]
+    exact (ReferenceVerifierWitness.canonicalReferenceWords_root key f root dummy).symm
+  rw [canonicalGraphLabels_frontier key.parameter key.otsSecret key.ftsSecret f _ root, hw] at hb
+  exact ReferenceSigningWitness.fixedTrace_origin { key with root := root } f _ _
+    (isSigningFrontier_canonical { key with root := root } f _)
+    (frontierReferenceWord_canonical { key with root := root } f dummy) _ before hb message signature hentry
+
+theorem referenceForgeryRest_certificate_atRoot (key : SecretKey) (f : QueryImpl HashSpec Id) (root : Digest)
+    (hroot : root = (ReferenceVerifierWitness.rootedKey key f).root)
+    (dummy : OtsReferenceWords) (adversary : Adversary) (before : AdversaryTrace)
+    (hb : before ∈ support (referenceForgeryRest key f (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f)
+      (referenceTableSelection key f) dummy adversary))
+    (trace : Trace) (required : Finset FtsTree)
+    (hcertificate : TargetCertificateAt { key with root := root } required
+      (ReferenceFtsCoverage.transcriptCache f before.1.2 trace, before.1.1.2)
+      (signingInput { key with root := root } before.1.1.1.message before.1.1.1.signature)) :
+    TargetCertificateAt { key with root := root } required
+      (hashRowsCache (completeCertificateRest { key with root := root } f before.1).2.messageCalls, before.1.1.2)
+      (signingInput { key with root := root } before.1.1.1.message before.1.1.1.signature) :=
+  certificate_to_message_record { key with root := root } f before.1 trace required
+    (referenceForgeryRest_origin_atRoot key f root hroot dummy adversary before hb)
+    (referenceForgeryRest_traceValid_atRoot key f root hroot dummy adversary before hb) hcertificate
+
+noncomputable def ReferenceForgerySample.fullCertificate {inputs : Finset HashInput} (dummy : OtsReferenceWords)
+    (sample : ReferenceForgerySample inputs) : Prop :=
+  let f := finiteHashAnswer ∅ inputs sample.2.1.2
+  let key := ReferenceVerifierWitness.rootedKey sample.1 f
+  let result := (sample.context dummy).2.2.2
+  SigningTranscript.Valid sample.2.2.1.1.2 ∧
+    TargetCertificateAt key Finset.univ
+      (ReferenceFtsCoverage.transcriptCache f sample.2.2.1.2 (result.before * result.after), sample.2.2.1.1.2)
+      (signingInput key sample.2.2.1.1.1.message sample.2.2.1.1.1.signature)
+
+noncomputable def ReferenceForgerySample.remainingFts {inputs : Finset HashInput} (dummy : OtsReferenceWords)
+    (sample : ReferenceForgerySample inputs) : Prop :=
+  let f := finiteHashAnswer ∅ inputs sample.2.1.2
+  let key := ReferenceVerifierWitness.rootedKey sample.1 f
+  let result := (sample.context dummy).2.2.2
+  SigningTranscript.Valid sample.2.2.1.1.2 ∧
+    (ReferenceFtsCoverage.NearGuess key f sample.2.2.1.1.2 sample.2.2.1.2 (result.before * result.after) sample.2.2.1.1.1 ∨
+      ReferenceFtsCoverage.TwoGuesses key f sample.2.2.1.1.2 (result.before * result.after) sample.2.2.1.1.1)
+
+theorem ReferenceForgerySample.ftsOutcome_cases {inputs : Finset HashInput} (dummy : OtsReferenceWords)
+    (sample : ReferenceForgerySample inputs) (h : sample.ftsOutcome dummy) :
+    sample.fullCertificate dummy ∨ sample.remainingFts dummy := by
+  rcases h with ⟨hvalid, hfull | hrest⟩
+  · exact Or.inl ⟨hvalid, hfull⟩
+  · exact Or.inr ⟨hvalid, hrest⟩
+
+theorem referenceForgeryGame_full_record (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) (sample : ReferenceForgerySample inputs)
+    (hsample : sample ∈ support (referenceForgeryGame inputs hencoding dummy adversary))
+    (hfull : sample.fullCertificate dummy) : sample.certificateRecord.full := by
+  obtain ⟨href, hb⟩ := referenceForgeryGame_support inputs hencoding dummy adversary sample hsample
+  rw [referenceFamilyOracleSample_selections sample.1 inputs (hencoding sample.1.parameter)
+    (hgraph sample.1.parameter) sample.2.1 href] at hb
+  refine ⟨hfull.1, signingInput (ReferenceVerifierWitness.rootedKey sample.1 (finiteHashAnswer ∅ inputs sample.2.1.2))
+    sample.2.2.1.1.1.message sample.2.2.1.1.1.signature, ?_⟩
+  exact referenceForgeryRest_certificate_atRoot sample.1 (finiteHashAnswer ∅ inputs sample.2.1.2) _ rfl
+    dummy adversary sample.2.2 hb _ Finset.univ hfull.2
+
+private theorem probEvent_le_project {Source Result : Type} (source : SPMF Source) (native : ProbComp Result)
+    (projection : Source → Result) (event : Source → Prop) (nativeEvent : Result → Prop)
+    (hlaw : projection <$> source = 𝒟[native])
+    (hevent : ∀ sample ∈ support source, event sample → nativeEvent (projection sample)) :
+    Pr[event | source] ≤ Pr[nativeEvent | native] := by
+  calc
+    _ ≤ Pr[nativeEvent ∘ projection | source] := _root_.probEvent_mono hevent
+    _ = Pr[nativeEvent | projection <$> source] := (probEvent_map source projection nativeEvent).symm
+    _ = Pr[nativeEvent | native] := by rw [hlaw]; rfl
+
+theorem referenceForgeryGame_full_le (dummy : OtsReferenceWords) (adversary : Adversary) :
+    Pr[ReferenceForgerySample.fullCertificate dummy | referenceForgeryGame (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] ≤
+      Pr[OriginalFullCertificate | originalCertificateSource adversary] :=
+  (probEvent_le_project _ _ ReferenceForgerySample.certificateRecord (ReferenceForgerySample.fullCertificate dummy)
+    CertificateTraceRecord.full (referenceForgeryGame_native_certificateRecord dummy adversary)
+    (referenceForgeryGame_full_record _ _ (canonicalGraphInputs_subset_gameInputs adversary) dummy adversary)).trans
+      (certificateTraceProgram_full_le adversary)
+
+theorem forgeAdvantage_le_remainingFts_small_budget (dummy : OtsReferenceWords)
+    (hdummy : ∀ lay tree leaf, TargetSum.Valid (dummy lay tree leaf))
+    (adversary : Adversary) (q : Nat) (hbound : HasHashQueryBound scheme adversary q)
+    (hsmall : q ≤ 3 * 2 ^ 114) :
+    forgeAdvantage scheme adversary ≤
+      (7 / 4 : ENNReal) * ((q : ENNReal) / 2 ^ 128) + (q : ENNReal) * (11 / 2 ^ 144 : ENNReal) +
+      (2 ^ 700 : ENNReal)⁻¹ +
+      Pr[ReferenceForgerySample.remainingFts dummy | referenceForgeryGame (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] := by
+  have hfts : Pr[ReferenceForgerySample.ftsOutcome dummy | referenceForgeryGame (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] ≤
+      Pr[OriginalFullCertificate | originalCertificateSource adversary] +
+      Pr[ReferenceForgerySample.remainingFts dummy | referenceForgeryGame (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] := by
+    refine (_root_.probEvent_mono (mx := referenceForgeryGame (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary)
+      (p := ReferenceForgerySample.ftsOutcome dummy)
+      (q := fun sample => sample.fullCertificate dummy ∨ sample.remainingFts dummy)
+      (fun sample _ h => sample.ftsOutcome_cases dummy h)).trans ?_
+    exact (probEvent_or_le _ _ _).trans (add_le_add (referenceForgeryGame_full_le dummy adversary) le_rfl)
+  have h := (forgeAdvantage_le_referenceForgery_cases dummy hdummy adversary).trans (add_le_add hfts le_rfl)
+  rw [add_right_comm, add_comm (Pr[OriginalFullCertificate | originalCertificateSource adversary])] at h
+  exact h.trans (add_le_add (original_primitive_add_full_certificate_small_budget dummy adversary q hbound hsmall) le_rfl)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceCertificateTrace.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceCertificateTrace.lean
new file mode 100644
index 000000000..a52f8c504
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceCertificateTrace.lean
@@ -0,0 +1,168 @@
+import SphincsSecurity.Proof.Fts.OriginalCertificateTrace
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec OtsContactTrace OracleComp.DeferredSampling
+open FtsProbeSimulation (RetainedRestResult retainedGameRestComputation)
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] scheme frontierRoot canonicalGraphLabels canonicalGraphInputs canonicalEncodingInputs
+  canonicalGraphGameInputs hashInputs treeRoot honestNode
+
+noncomputable def completeCertificateRest (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (before : (Forgery × QueryLog SigningSpec) × SigningBoundaryTrace) : RetainedRestResult × SigningBoundaryTrace :=
+  let checked := boundaryEval key.parameter f (verify ⟨key.root, key.parameter⟩ before.1.1.message before.1.1.signature)
+  ((before.1, checked.1), before.2 * checked.2)
+
+theorem fixedBoundaryRun_retained_frontier (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (hfrontier : IsSigningFrontier key f words frontier)
+    (hwords : ∀ index lay, FrontierReferenceWord key.parameter f key.ftsSecret words frontier index lay)
+    (adversary : Adversary) :
+    fixedBoundaryRun key.parameter f (simulateQ (expandedAdversaryImpl key)
+      (retainedGameRestComputation adversary ⟨key.root, key.parameter⟩)) =
+    completeCertificateRest key f <$> frontierAdversaryRun key.parameter key.root f key.ftsSecret words frontier
+      (adversary.main ⟨key.root, key.parameter⟩) := by
+  rw [retainedGameRestComputation, simulateQ_bind,
+    ← FtsProbeSimulation.simulateQ_withTraceAppend_run_eq_signingTraceComputation,
+    ← forwardOracles_add_signingOracle_eq_withTraceAppend, fixedBoundaryRun_bind,
+    fixedBoundaryRun_adversary_frontier key f words frontier hfrontier hwords, map_eq_bind_pure_comp]
+  apply bind_congr
+  rintro ⟨⟨forgery, log⟩, trace⟩
+  rw [simulateQ_bind, FtsProbeSimulation.simulateQ_expanded_liftOracleWorldLeft]
+  simp only [simulateQ_pure, bind_pure_comp, fixedBoundaryRun_map, scheme]
+  change (fun final => (final.1, trace * final.2)) <$>
+    (Prod.map (fun checked => ((forgery, log), checked)) id) <$>
+      fixedBoundaryRun key.parameter f (liftM (verify (m := OracleComp HashSpec) ⟨key.root, key.parameter⟩ forgery.message forgery.signature)) = _
+  rw [fixedBoundaryRun_lift_hash, map_pure, map_pure]
+  rfl
+
+noncomputable def ReferenceForgerySample.certificateRecord {inputs : Finset HashInput}
+    (sample : ReferenceForgerySample inputs) : CertificateTraceRecord :=
+  let f := finiteHashAnswer ∅ inputs sample.2.1.2
+  let key := ReferenceVerifierWitness.rootedKey sample.1 f
+  let result := completeCertificateRest key f sample.2.2.1
+  (key, result.1, result.2)
+
+theorem referenceForgeryRest_certificateRecord_atRoot (key : SecretKey) (f : QueryImpl HashSpec Id) (root : Digest)
+    (hroot : root = (ReferenceVerifierWitness.rootedKey key f).root)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (fun before : AdversaryTrace =>
+      let result := completeCertificateRest ({ key with root := root } : SecretKey) f before.1
+      (({ key with root := root } : SecretKey), result.1, result.2)) <$>
+      referenceForgeryRest key f (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f)
+        (referenceTableSelection key f) dummy adversary =
+    (fun result : RetainedRestResult × SigningBoundaryTrace =>
+      (({ key with root := root } : SecretKey), result.1, result.2)) <$>
+      fixedBoundaryRun key.parameter f (simulateQ (expandedAdversaryImpl ({ key with root := root } : SecretKey))
+        (retainedGameRestComputation adversary ⟨root, key.parameter⟩)) := by
+  rw [referenceForgeryRest, ReferenceVerifierWitness.source_root, ← hroot]
+  have hw : referenceFamilyWords (referenceTableSelection key f) dummy =
+      canonicalReferenceWords ({ key with root := root } : SecretKey) f dummy := by
+    rw [referenceFamilyWords_selected]
+    exact (ReferenceVerifierWitness.canonicalReferenceWords_root key f root dummy).symm
+  rw [canonicalGraphLabels_frontier key.parameter key.otsSecret key.ftsSecret f _ root, hw]
+  rw [fixedBoundaryRun_retained_frontier ({ key with root := root } : SecretKey) f _ _
+    (isSigningFrontier_canonical ({ key with root := root } : SecretKey) f _)
+    (frontierReferenceWord_canonical ({ key with root := root } : SecretKey) f dummy), Functor.map_map]
+  have h := congrArg (Functor.map (fun before =>
+    let result := completeCertificateRest ({ key with root := root } : SecretKey) f before
+    (({ key with root := root } : SecretKey), result.1, result.2)))
+    (fixedTrace_forget f (CausalFrontierProgram.adversaryRun key.parameter root f key.ftsSecret
+      (canonicalReferenceWords ({ key with root := root } : SecretKey) f dummy)
+      (canonicalFrontierValues ({ key with root := root } : SecretKey) f (canonicalReferenceWords ({ key with root := root } : SecretKey) f dummy))
+      (adversary.main ⟨root, key.parameter⟩)))
+  rw [Functor.map_map, CausalFrontierProgram.fixed_adversaryRun] at h
+  exact h
+
+private theorem fixedHashWorld_lift_hash {Result : Type} (f : QueryImpl HashSpec Id)
+    (computation : OracleComp HashSpec Result) :
+    simulateQ (fixedHashWorld f) (liftM computation : OracleComp OracleWorld Result) = pure (evalWithAnswerFn f computation) := by
+  have h := fixedBoundaryRun_forget 0 f (liftM computation : OracleComp OracleWorld Result)
+  rw [fixedBoundaryRun_lift_hash, map_pure, boundaryEval_fst] at h
+  exact h.symm
+
+private theorem rootedKey_root_eq_treeRoot (key : SecretKey) (f : QueryImpl HashSpec Id) :
+    (ReferenceVerifierWitness.rootedKey key f).root =
+      evalWithAnswerFn f (treeRoot key.parameter topLayer rootTree (key.otsSecret topLayer rootTree)) := by
+  simp only [honestNode, treeRoot]
+
+noncomputable def fixedCertificateTraceGame (f : QueryImpl HashSpec Id) (adversary : Adversary) : ProbComp CertificateTraceRecord := do
+  let parameter ← sampleParameter
+  let otsSecret ← sampleOtsSecrets
+  let ftsSecret ← sampleFtsSecrets
+  let key := ReferenceVerifierWitness.rootedKey ⟨parameter, 0, otsSecret, ftsSecret⟩ f
+  let result ← fixedBoundaryRun parameter f (simulateQ (expandedAdversaryImpl key)
+    (retainedGameRestComputation adversary ⟨key.root, parameter⟩))
+  pure (key, result.1, result.2)
+
+theorem simulateQ_certificateTraceProgram (f : QueryImpl HashSpec Id) (adversary : Adversary) :
+    simulateQ (fixedHashWorld f) (certificateTraceProgram adversary) = fixedCertificateTraceGame f adversary := by
+  rw [certificateTraceProgram, show scheme.keygen = keygen by rw [scheme], keygen, fixedCertificateTraceGame]
+  simp only [simulateQ_bind, simulateQ_fixedHashWorld_lift_prob, fixedHashWorld_lift_hash, simulateQ_pure,
+    bind_assoc, pure_bind]
+  apply bind_congr
+  intro parameter
+  apply bind_congr
+  intro otsSecret
+  apply bind_congr
+  intro ftsSecret
+  rw [← fixedBoundaryRun_eq_boundaryComputation, ← rootedKey_root_eq_treeRoot ⟨parameter, 0, otsSecret, ftsSecret⟩ f]
+
+noncomputable def referenceCertificateRest (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords) (adversary : Adversary) : ProbComp CertificateTraceRecord :=
+  (fun before =>
+    let actualKey := ReferenceVerifierWitness.rootedKey key f
+    let result := completeCertificateRest actualKey f before.1
+    (actualKey, result.1, result.2)) <$>
+      referenceForgeryRest key f (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f) selections dummy adversary
+
+theorem referenceCertificateRest_selected (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    referenceCertificateRest key f (referenceTableSelection key f) dummy adversary =
+      (fun result : RetainedRestResult × SigningBoundaryTrace =>
+        (ReferenceVerifierWitness.rootedKey key f, result.1, result.2)) <$>
+        fixedBoundaryRun key.parameter f (simulateQ (expandedAdversaryImpl (ReferenceVerifierWitness.rootedKey key f))
+          (retainedGameRestComputation adversary ⟨(ReferenceVerifierWitness.rootedKey key f).root, key.parameter⟩)) :=
+  referenceForgeryRest_certificateRecord_atRoot key f _ rfl dummy adversary
+
+theorem referenceForgeryGame_certificateRecord (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    ReferenceForgerySample.certificateRecord <$> referenceForgeryGame inputs hencoding dummy adversary =
+      𝒟[do
+        let table ← sampleHashTable inputs
+        fixedCertificateTraceGame (finiteHashAnswer ∅ inputs table) adversary] := by
+  rw [referenceForgeryGame]
+  simp only [map_bind, map_pure, fixedCertificateTraceGame]
+  rw [evalDist_bind_comm, evalDist_bind]
+  apply congrArg (𝒟[sampleParameter] >>= ·)
+  funext parameter
+  rw [evalDist_bind_comm, evalDist_bind]
+  apply congrArg (𝒟[sampleOtsSecrets] >>= ·)
+  funext otsSecret
+  rw [evalDist_bind_comm, evalDist_bind]
+  apply congrArg (𝒟[sampleFtsSecrets] >>= ·)
+  funext ftsSecret
+  simp only [ReferenceForgerySample.certificateRecord, bind_pure_comp, ← evalDist_map]
+  change (𝒟[referenceFamilyOracleSample ⟨parameter, 0, otsSecret, ftsSecret⟩ inputs (hencoding parameter)] >>= fun reference =>
+    𝒟[referenceCertificateRest ⟨parameter, 0, otsSecret, ftsSecret⟩ (finiteHashAnswer ∅ inputs reference.2) reference.1 dummy adversary]) = _
+  rw [referenceFamilyOracleSample_bind_selected ⟨parameter, 0, otsSecret, ftsSecret⟩ inputs (hencoding parameter) (hgraph parameter)
+    (fun selections table => referenceCertificateRest ⟨parameter, 0, otsSecret, ftsSecret⟩
+      (finiteHashAnswer ∅ inputs table) selections dummy adversary)]
+  apply evalDist_bind_congr_left
+  intro table
+  rw [referenceCertificateRest_selected]
+
+theorem referenceForgeryGame_native_certificateRecord (dummy : OtsReferenceWords) (adversary : Adversary) :
+    ReferenceForgerySample.certificateRecord <$>
+      referenceForgeryGame (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary =
+        𝒟[(simulateQ romImpl (certificateTraceProgram adversary)).run' ∅] := by
+  rw [referenceForgeryGame_certificateRecord _ _ (canonicalGraphInputs_subset_gameInputs adversary),
+    evalDist_romRun_eq_finiteHash _ (canonicalGraphGameInputs adversary)
+      (by rw [certificateTraceProgram_hashInputs]; exact hashInputs_subset_canonicalGraphGameInputs adversary) ∅]
+  apply evalDist_bind_congr_left
+  intro table
+  exact congrArg evalDist (simulateQ_certificateTraceProgram (finiteHashAnswer ∅ (canonicalGraphGameInputs adversary) table) adversary).symm
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceContactGame.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceContactGame.lean
new file mode 100644
index 000000000..0fe3a448e
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceContactGame.lean
@@ -0,0 +1,98 @@
+import SphincsSecurity.Proof.Ots.OtsContactSplit
+import SphincsSecurity.Proof.Reference.ReferenceInstrumentedGame
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphInputs canonicalEncodingInputs canonicalGraphGameInputs OtsContactTrace.contacts
+
+structure ContactResult where
+  frontier : OtsFrontierValues
+  before : OtsContactTrace.Trace
+  output : Bool × SigningBoundaryTrace
+  after : OtsContactTrace.Trace
+
+noncomputable def contactObserver : FrontierObserver ContactResult := fun parameter words frontier computation =>
+  (fun result => ⟨frontier, result.1, result.2.1, result.2.2⟩) <$> OtsContactTrace.splitRun parameter words frontier computation
+
+theorem contactObserver_frontier_trace (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (computation : OracleComp OracleWorld (Bool × SigningBoundaryTrace)) :
+    (fun result : ContactResult => (result.frontier, result.output, result.before * result.after)) <$>
+      contactObserver parameter words frontier computation =
+        (fun result => (frontier, result)) <$> QueryPause.traced hashObservationTrace computation := by
+  simpa only [contactObserver, Functor.map_map] using
+    congrArg (Functor.map (fun result => (frontier, result))) (OtsContactTrace.splitRun_trace parameter words frontier computation)
+
+theorem contactObserver_forget (parameter : PublicParameter) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (computation : OracleComp OracleWorld (Bool × SigningBoundaryTrace)) :
+    ContactResult.output <$> contactObserver parameter words frontier computation = computation := by
+  simpa only [contactObserver, Functor.map_map] using OtsContactTrace.splitRun_forget parameter words frontier computation
+
+noncomputable abbrev referenceContactGame (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (dummy : OtsReferenceWords) (adversary : Adversary) :=
+  referenceInstrumentedGame contactObserver inputs hencoding dummy adversary
+
+theorem referenceContactGame_erased (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (fun result => (result.2.1, result.2.2.output)) <$> referenceContactGame inputs hencoding dummy adversary =
+      referenceFamilyGame inputs hencoding dummy adversary :=
+  referenceInstrumentedGame_erased contactObserver ContactResult.output contactObserver_forget inputs hencoding dummy adversary
+
+theorem forgeAdvantage_eq_referenceContact (dummy : OtsReferenceWords) (adversary : Adversary) :
+    forgeAdvantage scheme adversary = Pr[fun result => result.2.2.output.1 = true |
+      referenceContactGame (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] := by
+  rw [forgeAdvantage_eq_referenceFamily dummy adversary, ← referenceContactGame_erased, probEvent_map]
+  rfl
+
+theorem referenceContactGame_hashCalls_le (dummy : OtsReferenceWords) (adversary : Adversary) (budget : Nat)
+    (hbound : HasHashQueryBound scheme adversary budget) (result : InstrumentedResult ContactResult)
+    (hresult : result ∈ support (referenceContactGame (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary)) : result.2.2.output.2.hashCalls ≤ budget := by
+  apply referenceFamilyGame_hashCalls_le dummy adversary budget hbound (result.2.1, result.2.2.output)
+  rw [← referenceContactGame_erased, support_map]
+  exact ⟨result, hresult, rfl⟩
+
+theorem contactObserver_cost (parameter : PublicParameter) (external : QueryImpl HashSpec Id)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (words : OtsReferenceWords) (frontier : OtsFrontierValues)
+    (adversary : Adversary) (result : ContactResult)
+    (hresult : result ∈ support (contactObserver parameter words frontier
+      (CausalFrontierProgram.game parameter external ftsSecret words frontier adversary))) :
+    (result.before * result.after).toList.length ≤ result.output.2.hashCalls := by
+  rw [contactObserver, support_map] at hresult
+  obtain ⟨split, hsplit, rfl⟩ := hresult
+  exact OtsContactTrace.splitRun_game_cost parameter words frontier external ftsSecret adversary split hsplit
+
+theorem referenceContactGame_cost (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (dummy : OtsReferenceWords) (adversary : Adversary)
+    (result : InstrumentedResult ContactResult) (hresult : result ∈ support (referenceContactGame inputs hencoding dummy adversary)) :
+    (result.2.2.before * result.2.2.after).toList.length ≤ result.2.2.output.2.hashCalls := by
+  simp only [referenceContactGame, referenceInstrumentedGame, mem_support_bind_iff] at hresult
+  obtain ⟨parameter, _, otsSecret, _, ftsSecret, _, reference, _, output, houtput, hresult⟩ := hresult
+  rw [mem_support_pure_iff] at hresult
+  subst result
+  have hsyntax := (mem_support_iff_of_evalDist_eq (mx := referenceInstrumentedRest contactObserver _ _ _ _ dummy adversary)
+    (mx' := 𝒟[referenceInstrumentedRest contactObserver _ _ _ _ dummy adversary]) rfl output).mpr houtput
+  exact contactObserver_cost _ _ _ _ _ adversary output (QueryCap.simulate_oracle_mem_support _ _ output hsyntax)
+
+def ContactResult.Marked (parameter : PublicParameter) (words : OtsReferenceWords) (result : ContactResult) : Prop :=
+  OtsContactTrace.Stopped parameter words result.frontier result.before
+
+noncomputable def ContactResult.restartCharge (parameter : PublicParameter) (words : OtsReferenceWords)
+    (address : OtsPrefix.ChainAddress) (result : ContactResult) : Nat :=
+  if result.Marked parameter words ∧ address ∉ OtsContactTrace.contacts parameter words result.frontier result.before then
+    OtsContactTrace.prefixCalls (OtsPrefix.atAddress parameter words address) result.before +
+      2 * OtsContactTrace.prefixCalls (OtsPrefix.atAddress parameter words address) result.after
+  else 0
+
+theorem ContactResult.restartCharge_sum_le (parameter : PublicParameter) (words : OtsReferenceWords)
+    (result : ContactResult) (budget : Nat) (hbudget : (result.before * result.after).toList.length ≤ budget) :
+    (∑ address : OtsPrefix.ChainAddress, result.restartCharge parameter words address) ≤
+      if result.Marked parameter words then 2 * budget else 0 := by
+  by_cases hm : result.Marked parameter words
+  · simp only [ContactResult.restartCharge, hm, true_and, if_true]
+    rw [← Finset.sum_filter]
+    exact OtsContactTrace.restartCharge_le_budget parameter words _ result.before result.after budget hbudget
+  · simp only [ContactResult.restartCharge, hm, false_and, if_false, Finset.sum_const_zero, le_refl]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceForgeryAuxiliary.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceForgeryAuxiliary.lean
new file mode 100644
index 000000000..62ff8fd55
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceForgeryAuxiliary.lean
@@ -0,0 +1,60 @@
+import SphincsSecurity.Proof.Forced.FtsGuessReference
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec OtsContactTrace
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs canonicalGraphGameInputs instFintypePosition
+  frontierRoot maskOtsPrefixes frontierSigningRun boundaryEval
+
+theorem referenceFamilyOracleSample_auxiliary_bind {Result : Type} (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (hgraph : canonicalGraphInputs key.parameter ⊆ inputs)
+    (next : QueryImpl HashSpec Id → CanonicalGraphLabels → ReferenceFamily → ProbComp Result) :
+    (𝒟[referenceFamilyOracleSample key inputs hencoding] >>= fun reference =>
+      let f := finiteHashAnswer ∅ inputs reference.2
+      𝒟[next f (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f) reference.1]) = (do
+        let auxiliary ← 𝒟[referenceAuxiliarySample inputs]
+        let labels ← 𝒟[PMF.uniformOfFintype CanonicalGraphLabels]
+        let f := programmedHash key.parameter key.otsSecret key.ftsSecret labels
+          (finiteHashAnswer ∅ inputs (canonicalReferenceResidual key.parameter inputs hencoding labels auxiliary.rows auxiliary.seed))
+        𝒟[next f labels auxiliary.selections]) := by
+  have hfirst := referenceFamilyOracleSample_graph_bind key inputs hencoding hgraph next
+  have hsecond := graphReferenceSample_bind_selected key inputs hencoding
+    (fun selections labels residual => next
+      (programmedHash key.parameter key.otsSecret key.ftsSecret labels (finiteHashAnswer ∅ inputs residual)) labels selections)
+  have h := hfirst.trans hsecond.symm
+  rw [h]
+  simp only [graphReferenceSample_eq_auxiliary, ← PMF.monad_bind_eq_bind, ← PMF.monad_map_eq_map,
+    evalDist_bind, evalDist_map, bind_assoc, bind_map_left]
+
+theorem referenceForgeryGame_bind_auxiliary {Result : Type} (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary)
+    (next : SecretKey → QueryImpl HashSpec Id → CanonicalGraphLabels → ReferenceFamily → AdversaryTrace → ProbComp Result) :
+    (referenceForgeryGame inputs hencoding dummy adversary >>= fun sample =>
+      let f := finiteHashAnswer ∅ inputs sample.2.1.2
+      𝒟[next sample.1 f (canonicalGraphLabels sample.1.parameter sample.1.otsSecret sample.1.ftsSecret f) sample.2.1.1 sample.2.2]) = (do
+        let parameter ← 𝒟[sampleParameter]
+        let otsSecret ← 𝒟[sampleOtsSecrets]
+        let ftsSecret ← 𝒟[sampleFtsSecrets]
+        let key : SecretKey := ⟨parameter, 0, otsSecret, ftsSecret⟩
+        let auxiliary ← 𝒟[referenceAuxiliarySample inputs]
+        let labels ← 𝒟[PMF.uniformOfFintype CanonicalGraphLabels]
+        let f := programmedHash parameter otsSecret ftsSecret labels
+          (finiteHashAnswer ∅ inputs (canonicalReferenceResidual parameter inputs (hencoding parameter) labels auxiliary.rows auxiliary.seed))
+        let before ← 𝒟[referenceForgeryRest key f labels auxiliary.selections dummy adversary]
+        𝒟[next key f labels auxiliary.selections before]) := by
+  simp only [referenceForgeryGame, bind_assoc, pure_bind]
+  apply congrArg (𝒟[sampleParameter] >>= ·)
+  funext parameter
+  apply congrArg (𝒟[sampleOtsSecrets] >>= ·)
+  funext otsSecret
+  apply congrArg (𝒟[sampleFtsSecrets] >>= ·)
+  funext ftsSecret
+  have h := referenceFamilyOracleSample_auxiliary_bind ⟨parameter, 0, otsSecret, ftsSecret⟩ inputs
+    (hencoding parameter) (hgraph parameter) (fun f labels selections => do
+      let before ← referenceForgeryRest ⟨parameter, 0, otsSecret, ftsSecret⟩ f labels selections dummy adversary
+      next ⟨parameter, 0, otsSecret, ftsSecret⟩ f labels selections before)
+  simpa only [evalDist_bind] using h
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceForgeryCoverage.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceForgeryCoverage.lean
new file mode 100644
index 000000000..47236c1dc
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceForgeryCoverage.lean
@@ -0,0 +1,45 @@
+import SphincsSecurity.Proof.Fts.ReferenceFtsCoverage
+import SphincsSecurity.Proof.Reference.ReferencePrimitiveWitness
+namespace SphincsSecurity.Concrete.ReferenceVerifierWitness
+
+open _root_.OracleComp OracleSpec OtsContactTrace OtsVerifierWitness
+open RetainedResidual (signingInput)
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] frontierRoot canonicalGraphInputs canonicalEncodingInputs instFintypePosition chainWalk sequenceFin
+
+def ForgeryWitnessFor (key : SecretKey) (f : QueryImpl HashSpec Id) (root : Digest) (words : OtsReferenceWords)
+    (selections : ReferenceFamily) (adversary : Adversary) (result : ContactResult) (before : AdversaryTrace) : Prop :=
+  let actualKey : SecretKey := { key with root := root }
+  let labels := canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f
+  let frontier := canonicalGraphFrontier key.otsSecret labels words
+  let trace := result.before * result.after
+  before ∈ support (fixedTrace f (CausalFrontierProgram.adversaryRun key.parameter actualKey.root f key.ftsSecret words frontier
+    (adversary.main ⟨actualKey.root, key.parameter⟩))) ∧
+  SigningTranscript.Valid before.1.1.2 ∧ ¬SigningTranscript.Contains before.1.1.2 before.1.1.1 ∧
+  (∀ message signature, (⟨message, some signature⟩ : SigningEntry) ∈ before.1.1.2 →
+    ReferenceSigningWitness.SignatureOrigin actualKey f message signature before.1.2) ∧
+  result.frontier = frontier ∧
+  trace = before.2 * answerTrace f (verify ⟨actualKey.root, key.parameter⟩ before.1.1.1.message before.1.1.1.signature) ∧
+  (ReferenceFtsCoverage.Outcome actualKey f before.1.1.2 before.1.2 trace before.1.1.1 ∨
+    ReferencePrimitiveWitness.Outcome actualKey f words (canonicalGraphMessage labels) selections result)
+
+theorem SuccessWitnessFor.classification {key : SecretKey} {f : QueryImpl HashSpec Id} {root : Digest} {words : OtsReferenceWords}
+    {selections : ReferenceFamily} {adversary : Adversary} {result : ContactResult} {before : AdversaryTrace}
+    (h : SuccessWitnessFor key f root words selections adversary result before) : ForgeryWitnessFor key f root words selections adversary result before := by
+  obtain ⟨hb, hv, hf, horigin, hfrontier, ht, digest, hdigest, hrun, hadmissible, hcases⟩ := h
+  refine ⟨hb, hv, hf, horigin, hfrontier, ht, ?_⟩
+  have heval : evalWithAnswerFn f (messageDigest key.parameter root before.1.1.1.message before.1.1.1.signature.randomness) =
+      truncateMessageDigest (f (signingInput { key with root := root } before.1.1.1.message before.1.1.1.signature)) := rfl
+  have hd := hdigest.symm.trans heval
+  rcases hcases with ⟨_, _, hqueries, hnew⟩ | hlayer | hfts
+  · rw [hd] at hadmissible hqueries
+    exact Or.inl (ReferenceFtsCoverage.classification { key with root := root } f before.1.1.2 before.1.2
+      (result.before * result.after) before.1.1.1 horigin hnew hrun hadmissible hqueries)
+  · apply Or.inr
+    apply ReferencePrimitiveWitness.layer_exception { key with root := root } f words _ selections result ?_ hlayer
+    intro lay tree leaf chain
+    rw [hfrontier, canonicalGraphLabels_frontier key.parameter key.otsSecret key.ftsSecret f words root]
+    rfl
+  · exact Or.inr (Or.inr (Or.inl (ReferencePrimitiveWitness.fts_exception { key with root := root } f words _ _ hfts)))
+
+end SphincsSecurity.Concrete.ReferenceVerifierWitness
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceForgerySource.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceForgerySource.lean
new file mode 100644
index 000000000..7a077b1a9
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceForgerySource.lean
@@ -0,0 +1,252 @@
+import SphincsSecurity.Proof.Reference.ReferenceForgeryCoverage
+import SphincsSecurity.Proof.Reference.ReferencePrimitiveBound
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec OtsContactTrace
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] frontierRoot maskOtsPrefixes boundaryEval canonicalGraphInputs canonicalEncodingInputs
+  canonicalGraphGameInputs canonicalGraphLabels Finset.univ instFintypePosition chainWalk sequenceFin honestNode
+
+/-- Retains the whole trace with the split immediately before verification. -/
+noncomputable def completedReferenceContact (parameter : PublicParameter) (f : QueryImpl HashSpec Id)
+    (words : OtsReferenceWords) (frontier : OtsFrontierValues) (before : AdversaryTrace) : ContactResult :=
+  let root := frontierRoot parameter (maskOtsPrefixes parameter words f) words frontier
+  let checked := boundaryEval parameter f (verify ⟨root, parameter⟩ before.1.1.1.message before.1.1.1.signature)
+  { frontier := frontier
+    before := before.2
+    output := (decide (SigningTranscript.Valid before.1.1.2 ∧ ¬SigningTranscript.Contains before.1.1.2 before.1.1.1) && checked.1,
+      (FreeMonoid.of none) ^ 1212415 * (before.1.2 * checked.2))
+    after := answerTrace f (verify ⟨root, parameter⟩ before.1.1.1.message before.1.1.1.signature) }
+
+noncomputable def referenceForgeryRest (key : SecretKey) (f : QueryImpl HashSpec Id) (labels : CanonicalGraphLabels)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords) (adversary : Adversary) : ProbComp AdversaryTrace :=
+  let words := referenceFamilyWords selections dummy
+  let frontier := canonicalGraphFrontier key.otsSecret labels words
+  let root := frontierRoot key.parameter (maskOtsPrefixes key.parameter words f) words frontier
+  fixedTrace f (CausalFrontierProgram.adversaryRun key.parameter root f key.ftsSecret words frontier
+    (adversary.main ⟨root, key.parameter⟩))
+
+theorem referenceForgeryRest_trace (key : SecretKey) (f : QueryImpl HashSpec Id) (labels : CanonicalGraphLabels)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (fun before =>
+      let result := completedReferenceContact key.parameter f (referenceFamilyWords selections dummy)
+        (canonicalGraphFrontier key.otsSecret labels (referenceFamilyWords selections dummy)) before
+      (result.output, result.before * result.after)) <$> referenceForgeryRest key f labels selections dummy adversary =
+      fixedTrace f (CausalFrontierProgram.game key.parameter f key.ftsSecret (referenceFamilyWords selections dummy)
+        (canonicalGraphFrontier key.otsSecret labels (referenceFamilyWords selections dummy)) adversary) := by
+  rw [CausalFrontierProgram.game, fixedTrace_map, CausalFrontierProgram.gameRest, fixedTrace_bind]
+  simp only [fixedTrace_map, fixedTrace_boundary_hash, map_pure,
+    bind_pure_comp, Functor.map_map, completedReferenceContact, referenceForgeryRest]
+
+def ContactResult.traceView (result : ContactResult) : OtsFrontierValues × (Bool × SigningBoundaryTrace) × Trace :=
+  (result.frontier, result.output, result.before * result.after)
+
+theorem referenceForgeryRest_contact_trace (key : SecretKey) (f : QueryImpl HashSpec Id) (labels : CanonicalGraphLabels)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (fun before => (completedReferenceContact key.parameter f (referenceFamilyWords selections dummy)
+      (canonicalGraphFrontier key.otsSecret labels (referenceFamilyWords selections dummy)) before).traceView) <$>
+        referenceForgeryRest key f labels selections dummy adversary =
+      ContactResult.traceView <$> referenceInstrumentedRest contactObserver key f labels selections dummy adversary := by
+  have h := congrArg (Functor.map (fun result =>
+    (canonicalGraphFrontier key.otsSecret labels (referenceFamilyWords selections dummy), result)))
+    (referenceForgeryRest_trace key f labels selections dummy adversary)
+  simp only [Functor.map_map] at h
+  have hc (computation : OracleComp OracleWorld (Bool × SigningBoundaryTrace)) :
+      ContactResult.traceView <$> contactObserver key.parameter (referenceFamilyWords selections dummy)
+        (canonicalGraphFrontier key.otsSecret labels (referenceFamilyWords selections dummy)) computation =
+      (fun result => (canonicalGraphFrontier key.otsSecret labels (referenceFamilyWords selections dummy), result)) <$>
+        QueryPause.traced hashObservationTrace computation := contactObserver_frontier_trace _ _ _ computation
+  rw [referenceInstrumentedRest, ← simulateQ_map, hc, simulateQ_map]
+  exact h
+
+abbrev ReferenceForgerySample (inputs : Finset HashInput) := SecretKey × (ReferenceFamily × (inputs → HashOutput)) × AdversaryTrace
+
+noncomputable def referenceForgeryGame (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) : SPMF (ReferenceForgerySample inputs) := do
+  let parameter ← 𝒟[sampleParameter]
+  let otsSecret ← 𝒟[sampleOtsSecrets]
+  let ftsSecret ← 𝒟[sampleFtsSecrets]
+  let key : SecretKey := ⟨parameter, 0, otsSecret, ftsSecret⟩
+  let reference ← 𝒟[referenceFamilyOracleSample key inputs (hencoding parameter)]
+  let f := finiteHashAnswer ∅ inputs reference.2
+  let before ← 𝒟[referenceForgeryRest key f (canonicalGraphLabels parameter otsSecret ftsSecret f) reference.1 dummy adversary]
+  pure (key, reference, before)
+
+noncomputable def ReferenceForgerySample.context {inputs : Finset HashInput} (dummy : OtsReferenceWords)
+    (sample : ReferenceForgerySample inputs) : GraphContextResult ContactResult :=
+  let f := finiteHashAnswer ∅ inputs sample.2.1.2
+  let labels := canonicalGraphLabels sample.1.parameter sample.1.otsSecret sample.1.ftsSecret f
+  let words := referenceFamilyWords sample.2.1.1 dummy
+  (sample.1, labels, sample.2.1.1,
+    completedReferenceContact sample.1.parameter f words (canonicalGraphFrontier sample.1.otsSecret labels words) sample.2.2)
+
+abbrev GraphContextTraceResult := SecretKey × CanonicalGraphLabels × ReferenceFamily × OtsFrontierValues × (Bool × SigningBoundaryTrace) × Trace
+
+def graphContextTrace (result : GraphContextResult ContactResult) : GraphContextTraceResult :=
+  (result.1, result.2.1, result.2.2.1, result.2.2.2.traceView)
+
+theorem referenceForgeryGame_graph_trace (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (fun sample => graphContextTrace (sample.context dummy)) <$> referenceForgeryGame inputs hencoding dummy adversary =
+      graphContextTrace <$> referenceGraphContextGame contactObserver inputs hencoding dummy adversary := by
+  simp only [referenceForgeryGame, referenceGraphContextGame, referenceGraphContextRest, map_bind, map_pure,
+    bind_assoc, pure_bind, ReferenceForgerySample.context, graphContextTrace]
+  apply congrArg (𝒟[sampleParameter] >>= ·)
+  funext parameter
+  apply congrArg (𝒟[sampleOtsSecrets] >>= ·)
+  funext otsSecret
+  apply congrArg (𝒟[sampleFtsSecrets] >>= ·)
+  funext ftsSecret
+  apply congrArg (𝒟[referenceFamilyOracleSample _ inputs (hencoding parameter)] >>= ·)
+  funext reference
+  have h := congrArg (Functor.map (fun result =>
+    ((⟨parameter, 0, otsSecret, ftsSecret⟩ : SecretKey),
+      canonicalGraphLabels parameter otsSecret ftsSecret (finiteHashAnswer ∅ inputs reference.2), reference.1, result)))
+    (referenceForgeryRest_contact_trace ⟨parameter, 0, otsSecret, ftsSecret⟩ (finiteHashAnswer ∅ inputs reference.2)
+      (canonicalGraphLabels parameter otsSecret ftsSecret (finiteHashAnswer ∅ inputs reference.2)) reference.1 dummy adversary)
+  have hd := congrArg (fun law : ProbComp GraphContextTraceResult => 𝒟[law]) h
+  simpa only [Functor.map_map, evalDist_map, bind_pure_comp] using hd
+
+noncomputable def GraphContextTraceResult.primitive (dummy : OtsReferenceWords) (result : GraphContextTraceResult) : Prop :=
+  GraphPrimitiveEvent dummy (result.1, result.2.1, result.2.2.1,
+    ⟨result.2.2.2.1, result.2.2.2.2.2, result.2.2.2.2.1, 1⟩)
+
+theorem graphContextTrace_primitive (dummy : OtsReferenceWords) (result : GraphContextResult ContactResult) :
+    (graphContextTrace result).primitive dummy = GraphPrimitiveEvent dummy result := by
+  simp only [GraphContextTraceResult.primitive, graphContextTrace, ContactResult.traceView,
+    GraphPrimitiveEvent, ContactResult.TwoEdge, ContactResult.TwoEdgeAt, ContactResult.TwoContacts,
+    ContactResult.MarkerContact, mul_one]
+
+theorem referenceForgeryGame_primitive (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    Pr[fun sample => GraphPrimitiveEvent dummy (sample.context dummy) | referenceForgeryGame inputs hencoding dummy adversary] =
+      Pr[GraphPrimitiveEvent dummy | referenceGraphContextGame contactObserver inputs hencoding dummy adversary] := by
+  have h := congrArg (fun law => Pr[GraphContextTraceResult.primitive dummy | law])
+    (referenceForgeryGame_graph_trace inputs hencoding dummy adversary)
+  simpa only [probEvent_map, Function.comp_def, graphContextTrace_primitive] using h
+
+theorem referenceForgeryGame_verdict (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    Pr[fun sample => (sample.context dummy).2.2.2.output.1 = true | referenceForgeryGame inputs hencoding dummy adversary] =
+      Pr[fun result => result.2.2.2.output.1 = true | referenceGraphContextGame contactObserver inputs hencoding dummy adversary] := by
+  have h := congrArg (fun law => Pr[fun result : GraphContextTraceResult => result.2.2.2.2.1.1 = true | law])
+    (referenceForgeryGame_graph_trace inputs hencoding dummy adversary)
+  simpa only [probEvent_map, Function.comp_def, graphContextTrace, ContactResult.traceView] using h
+
+theorem forgeAdvantage_eq_referenceForgery (dummy : OtsReferenceWords) (adversary : Adversary) :
+    forgeAdvantage scheme adversary = Pr[fun sample => (sample.context dummy).2.2.2.output.1 = true |
+      referenceForgeryGame (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] := by
+  rw [referenceForgeryGame_verdict, forgeAdvantage_eq_referenceContact dummy adversary,
+    referenceGraphContextGame_contact_event _ _ dummy adversary (fun result => result.2.2.output.1 = true)]
+
+theorem referenceForgeryGame_support (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) (sample : ReferenceForgerySample inputs)
+    (hsample : sample ∈ support (referenceForgeryGame inputs hencoding dummy adversary)) :
+    sample.2.1 ∈ (referenceFamilyOracleSample sample.1 inputs (hencoding sample.1.parameter)).support ∧
+      sample.2.2 ∈ support (referenceForgeryRest sample.1 (finiteHashAnswer ∅ inputs sample.2.1.2)
+        (canonicalGraphLabels sample.1.parameter sample.1.otsSecret sample.1.ftsSecret (finiteHashAnswer ∅ inputs sample.2.1.2))
+        sample.2.1.1 dummy adversary) := by
+  simp only [referenceForgeryGame, mem_support_bind_iff] at hsample
+  obtain ⟨parameter, _, otsSecret, _, ftsSecret, _, reference, href, before, hb, heq⟩ := hsample
+  rw [mem_support_pure_iff] at heq
+  subst sample
+  constructor
+  · simpa only [PMF.evalDist_eq, SPMF.support_eq_support, SPMF.support_liftM] using href
+  · exact (mem_support_iff_of_evalDist_eq (mx := referenceForgeryRest _ _ _ _ dummy adversary)
+      (mx' := 𝒟[referenceForgeryRest _ _ _ _ dummy adversary]) rfl before).mpr hb
+
+theorem referenceForgeryRest_success (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords) (adversary : Adversary) (before : AdversaryTrace)
+    (hselected : selections = referenceTableSelection key f)
+    (hvalid : ∀ lay tree leaf, TargetSum.Valid (referenceFamilyWords selections dummy lay tree leaf))
+    (hb : before ∈ support (referenceForgeryRest key f (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f)
+      selections dummy adversary))
+    (hsuccess : (completedReferenceContact key.parameter f (referenceFamilyWords selections dummy)
+      (canonicalGraphFrontier key.otsSecret (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f)
+        (referenceFamilyWords selections dummy)) before).output.1 = true) :
+    ReferenceVerifierWitness.ForgeryWitnessFor key f (ReferenceVerifierWitness.rootedKey key f).root
+      (referenceFamilyWords selections dummy) selections adversary
+      (completedReferenceContact key.parameter f (referenceFamilyWords selections dummy)
+        (canonicalGraphFrontier key.otsSecret (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f)
+          (referenceFamilyWords selections dummy)) before) before := by
+  dsimp only [referenceForgeryRest] at hb
+  rw [ReferenceVerifierWitness.source_root] at hb
+  simp only [completedReferenceContact, ReferenceVerifierWitness.source_root, boundaryEval_fst,
+    Bool.and_eq_true, decide_eq_true_eq] at hsuccess
+  apply ReferenceVerifierWitness.SuccessWitnessFor.classification
+  apply ReferenceVerifierWitness.run_success_atRoot key f _ rfl selections dummy adversary _ before
+    hselected hvalid hb hsuccess.1.1 hsuccess.1.2 hsuccess.2 rfl
+  dsimp only [completedReferenceContact]
+  rw [ReferenceVerifierWitness.source_root]
+
+noncomputable def ReferenceForgerySample.ftsOutcome {inputs : Finset HashInput} (dummy : OtsReferenceWords)
+    (sample : ReferenceForgerySample inputs) : Prop :=
+  let f := finiteHashAnswer ∅ inputs sample.2.1.2
+  let result := (sample.context dummy).2.2.2
+  SigningTranscript.Valid sample.2.2.1.1.2 ∧
+    ReferenceFtsCoverage.Outcome (ReferenceVerifierWitness.rootedKey sample.1 f) f sample.2.2.1.1.2 sample.2.2.1.2
+      (result.before * result.after) sample.2.2.1.1.1
+
+theorem graphPrimitiveEvent_of_outcome_atRoot (key : SecretKey) (root : Digest) (f : QueryImpl HashSpec Id)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords) (result : ContactResult)
+    (h : ReferencePrimitiveWitness.Outcome { key with root := root } f (referenceFamilyWords selections dummy)
+      (canonicalGraphMessage (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f)) selections result) :
+    GraphPrimitiveEvent dummy (key, canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f, selections, result) := by
+  have hp := graphPrimitiveEvent_of_outcome { key with root := root } f selections dummy result h
+  simpa only [GraphPrimitiveEvent, ReferenceStructuralMatch.Seen, ReferenceStructuralMatch.Entry] using hp
+
+theorem referenceForgeryGame_success (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (hdummy : ∀ lay tree leaf, TargetSum.Valid (dummy lay tree leaf))
+    (adversary : Adversary) (sample : ReferenceForgerySample inputs)
+    (hsample : sample ∈ support (referenceForgeryGame inputs hencoding dummy adversary))
+    (hsuccess : (sample.context dummy).2.2.2.output.1 = true) :
+    sample.ftsOutcome dummy ∨ GraphPrimitiveEvent dummy (sample.context dummy) := by
+  obtain ⟨href, hb⟩ := referenceForgeryGame_support inputs hencoding dummy adversary sample hsample
+  have h := referenceForgeryRest_success sample.1 (finiteHashAnswer ∅ inputs sample.2.1.2) sample.2.1.1 dummy adversary sample.2.2
+    (referenceFamilyOracleSample_selections sample.1 inputs (hencoding sample.1.parameter) (hgraph sample.1.parameter) sample.2.1 href)
+    (referenceFamilyOracleSample_words_valid sample.1 inputs (hencoding sample.1.parameter) (hgraph sample.1.parameter) sample.2.1 href dummy hdummy)
+    hb hsuccess
+  dsimp only [ReferenceVerifierWitness.ForgeryWitnessFor] at h
+  obtain ⟨_, hvalidLog, _, _, _, _, hcases⟩ := h
+  rcases hcases with hfts | hprimitive
+  · exact Or.inl ⟨hvalidLog, hfts⟩
+  · apply Or.inr
+    dsimp only [ReferenceForgerySample.context]
+    exact graphPrimitiveEvent_of_outcome_atRoot sample.1
+      (ReferenceVerifierWitness.rootedKey sample.1 (finiteHashAnswer ∅ inputs sample.2.1.2)).root
+      (finiteHashAnswer ∅ inputs sample.2.1.2) sample.2.1.1 dummy _ hprimitive
+
+theorem referenceForgeryGame_cases (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (hdummy : ∀ lay tree leaf, TargetSum.Valid (dummy lay tree leaf)) (adversary : Adversary) :
+    Pr[fun sample => (sample.context dummy).2.2.2.output.1 = true | referenceForgeryGame inputs hencoding dummy adversary] ≤
+      Pr[ReferenceForgerySample.ftsOutcome dummy | referenceForgeryGame inputs hencoding dummy adversary] +
+      Pr[GraphPrimitiveEvent dummy | referenceGraphContextGame contactObserver inputs hencoding dummy adversary] := by
+  rw [← referenceForgeryGame_primitive inputs hencoding dummy adversary]
+  refine (_root_.probEvent_mono (mx := referenceForgeryGame inputs hencoding dummy adversary)
+    (p := fun sample => (sample.context dummy).2.2.2.output.1 = true)
+    (q := fun sample => sample.ftsOutcome dummy ∨ GraphPrimitiveEvent dummy (sample.context dummy)) ?_).trans (probEvent_or_le _ _ _)
+  intro sample hsample hsuccess
+  exact referenceForgeryGame_success inputs hencoding hgraph dummy hdummy adversary sample hsample hsuccess
+
+theorem forgeAdvantage_le_referenceForgery_cases (dummy : OtsReferenceWords)
+    (hdummy : ∀ lay tree leaf, TargetSum.Valid (dummy lay tree leaf)) (adversary : Adversary) :
+    forgeAdvantage scheme adversary ≤
+      Pr[ReferenceForgerySample.ftsOutcome dummy | referenceForgeryGame (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] +
+      Pr[GraphPrimitiveEvent dummy | referenceGraphContextGame contactObserver (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] := by
+  rw [forgeAdvantage_eq_referenceForgery dummy adversary]
+  exact referenceForgeryGame_cases (canonicalGraphGameInputs adversary) (canonicalEncodingInputs_subset_gameInputs adversary)
+    (canonicalGraphInputs_subset_gameInputs adversary) dummy hdummy adversary
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceInstrumentedGame.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceInstrumentedGame.lean
new file mode 100644
index 000000000..06566e87b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceInstrumentedGame.lean
@@ -0,0 +1,63 @@
+import SphincsSecurity.Proof.Ots.ReferenceFamilyAllocation
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalGraphInputs canonicalEncodingInputs canonicalGraphGameInputs
+
+abbrev FrontierObserver (Result : Type) := PublicParameter → OtsReferenceWords → OtsFrontierValues →
+  OracleComp OracleWorld (Bool × SigningBoundaryTrace) → OracleComp OracleWorld Result
+
+noncomputable def referenceInstrumentedRest {Result : Type} (observer : FrontierObserver Result)
+    (key : SecretKey) (oracle : QueryImpl HashSpec Id) (labels : CanonicalGraphLabels)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords) (adversary : Adversary) : ProbComp Result :=
+  let words := referenceFamilyWords selections dummy
+  let frontier := canonicalGraphFrontier key.otsSecret labels words
+  simulateQ (fixedHashWorld oracle) (observer key.parameter words frontier
+    (CausalFrontierProgram.game key.parameter oracle key.ftsSecret words frontier adversary))
+
+abbrev InstrumentedResult (Result : Type) := PublicParameter × ReferenceFamily × Result
+
+noncomputable def referenceInstrumentedGame {Result : Type} (observer : FrontierObserver Result)
+    (inputs : Finset HashInput) (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) : SPMF (InstrumentedResult Result) := do
+  let parameter ← 𝒟[sampleParameter]
+  let otsSecret ← 𝒟[sampleOtsSecrets]
+  let ftsSecret ← 𝒟[sampleFtsSecrets]
+  let key : SecretKey := ⟨parameter, 0, otsSecret, ftsSecret⟩
+  let reference ← 𝒟[referenceFamilyOracleSample key inputs (hencoding parameter)]
+  let oracle := finiteHashAnswer ∅ inputs reference.2
+  let result ← 𝒟[referenceInstrumentedRest observer key oracle
+    (canonicalGraphLabels parameter otsSecret ftsSecret oracle) reference.1 dummy adversary]
+  pure (parameter, reference.1, result)
+
+theorem referenceInstrumentedRest_erased {Result : Type} (observer : FrontierObserver Result)
+    (erase : Result → Bool × SigningBoundaryTrace)
+    (herase : ∀ parameter words frontier computation, erase <$> observer parameter words frontier computation = computation)
+    (key : SecretKey) (oracle : QueryImpl HashSpec Id) (labels : CanonicalGraphLabels)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    erase <$> referenceInstrumentedRest observer key oracle labels selections dummy adversary =
+      referenceFamilyFrontierRest key oracle labels selections dummy adversary := by
+  rw [referenceInstrumentedRest, ← simulateQ_map, herase, CausalFrontierProgram.fixed_game,
+    referenceFamilyFrontierRest, causalFrontierGame_eq]
+
+theorem referenceInstrumentedGame_erased {Result : Type} (observer : FrontierObserver Result)
+    (erase : Result → Bool × SigningBoundaryTrace)
+    (herase : ∀ parameter words frontier computation, erase <$> observer parameter words frontier computation = computation)
+    (inputs : Finset HashInput) (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (fun result => (result.2.1, erase result.2.2)) <$> referenceInstrumentedGame observer inputs hencoding dummy adversary =
+      referenceFamilyGame inputs hencoding dummy adversary := by
+  unfold referenceInstrumentedGame referenceFamilyGame
+  simp only [map_bind, map_pure]
+  apply congrArg (𝒟[sampleParameter] >>= ·)
+  funext parameter
+  apply congrArg (𝒟[sampleOtsSecrets] >>= ·)
+  funext otsSecret
+  apply congrArg (𝒟[sampleFtsSecrets] >>= ·)
+  funext ftsSecret
+  apply congrArg (𝒟[referenceFamilyOracleSample _ inputs (hencoding parameter)] >>= ·)
+  funext reference
+  rw [← referenceInstrumentedRest_erased observer erase herase, evalDist_map, bind_map_left]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceJointPrior.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceJointPrior.lean
new file mode 100644
index 000000000..a4e3d2572
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceJointPrior.lean
@@ -0,0 +1,31 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.AdaptiveResidualErasure
+import SphincsSecurity.Proof.Hypertree.CanonicalPublicPrior
+import SphincsSecurity.Proof.Reference.ReferenceResidualSeeds
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec UniformTableCompletion ResidualTableCompletion
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+structure ReferenceEncodingAuxiliary where
+  selections : ReferenceFamily
+  rows : CanonicalEncodingRows
+
+noncomputable def referenceEncodingAuxiliarySample : PMF ReferenceEncodingAuxiliary :=
+  (FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit).bind (fun selections =>
+    (FirstSuccessFamily.afterSelect decodeEncodingOutput encodingAttemptLimit decodeEncodingOutput_invalid_nonempty selections).map
+      (fun rows => ⟨selections, Function.uncurry rows⟩))
+
+theorem referenceAuxiliarySample_bind_seed {Result : Type} (inputs : Finset HashInput)
+    (next : ReferenceAuxiliary inputs → SPMF Result) :
+    (𝒟[referenceAuxiliarySample inputs] >>= next) =
+      (𝒟[referenceEncodingAuxiliarySample] >>= fun encoding =>
+        completeRows (fun _ : inputs => none) >>= fun seed => next ⟨encoding.selections, encoding.rows, seed⟩) := by
+  rw [completeRows_empty]
+  simp only [referenceAuxiliarySample, referenceEncodingAuxiliarySample,
+    ← PMF.monad_bind_eq_bind, ← PMF.monad_map_eq_map, evalDist_bind,
+    map_eq_bind_pure_comp, Function.comp_def, evalDist_pure, bind_assoc, pure_bind]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceOracleConditioning.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceOracleConditioning.lean
new file mode 100644
index 000000000..497cc17c8
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceOracleConditioning.lean
@@ -0,0 +1,49 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Ots.EncodingOracleSplit
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs
+set_option backward.isDefEq.respectTransparency false
+
+abbrev ReferenceSelection := Option (Fin encodingAttemptLimit × Encoding)
+
+noncomputable def referenceTableSelection (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (position : EncodingPosition) : ReferenceSelection :=
+  FirstSuccessTable.select decodeEncodingOutput (fun counter =>
+    readCanonicalEncodingRows key.parameter (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f)
+      f (position, counter))
+
+def referenceSelectionResult (selection : ReferenceSelection) : Option (Counter × Encoding) × Nat :=
+  (selection.map (fun result => (BitVec.ofNat counterBits result.1.val, result.2)),
+    selection.elim encodingAttemptLimit (fun result => result.1.val + 1))
+
+theorem referenceSelectionResult_eq_search (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (position : EncodingPosition) :
+    referenceSelectionResult (referenceTableSelection key f position) =
+      canonicalEncodingSearch key f position.lay position.tree position.leafIdx := by
+  rw [← congrFun (canonicalEncodingResults_eq key f) position]
+  simp only [canonicalEncodingResults, referenceSelectionResult, referenceTableSelection, encodingTableResult, Nat.zero_add]
+
+theorem referenceTableSelection_joinEncodingTable (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (hgraph : canonicalGraphInputs key.parameter ⊆ inputs)
+    (encoding : canonicalEncodingInputs key.parameter → HashOutput) (outside : NonencodingRows key.parameter inputs hencoding)
+    (position : EncodingPosition) :
+    referenceTableSelection key (finiteHashAnswer ∅ inputs (joinEncodingTable key.parameter inputs hencoding encoding outside))
+      position = FirstSuccessTable.select decodeEncodingOutput
+        (encoding ∘ referenceCounterCell key.parameter position (outsideGraphMessage key inputs hencoding outside position)) := by
+  rw [referenceTableSelection, canonicalGraphLabels_joinEncodingTable _ _ _ _ hencoding hgraph]
+  apply congrArg (FirstSuccessTable.select decodeEncodingOutput)
+  funext counter
+  change finiteHashAnswer ∅ inputs (joinEncodingTable key.parameter inputs hencoding encoding outside)
+    (encodingRetryInput key.parameter position (outsideGraphMessage key inputs hencoding outside position) counter.val) = _
+  rw [finiteHashAnswer_none ∅ inputs _ _
+    (hencoding (encodingRetryInput_mem_canonicalEncodingInputs _ _ _ counter)) (by simp)]
+  exact UniformTableSplit.join_embed _ _ encoding outside
+    (referenceCounterCell key.parameter position (outsideGraphMessage key inputs hencoding outside position) counter)
+
+noncomputable local instance instSampleableTypeForallSubtypeHashInputMemFinsetHashOutput_3 (inputs : Finset HashInput) : SampleableType (inputs → HashOutput) :=
+  SampleableType.ofFintype (inputs → HashOutput)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/ReferencePrimitiveBound.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferencePrimitiveBound.lean
new file mode 100644
index 000000000..903306eed
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferencePrimitiveBound.lean
@@ -0,0 +1,177 @@
+import SphincsSecurity.Proof.Hypertree.StructuralMatchBound
+import SphincsSecurity.Proof.Ots.EncodingMatchBound
+import SphincsSecurity.Proof.Ots.OtsDistinctContactBound
+import SphincsSecurity.Proof.Ots.OtsMarkerContactProbability
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphInputs canonicalEncodingInputs canonicalGraphGameInputs canonicalGraphLabels Finset.univ
+
+theorem referenceGraphContextGame_encoding {Result : Type} (observer : FrontierObserver Result)
+    (inputs : Finset HashInput) (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    (fun result : GraphContextResult Result => (result.1.parameter, result.2.2.1, canonicalGraphMessage result.2.1, result.2.2.2)) <$>
+      referenceGraphContextGame observer inputs hencoding dummy adversary =
+        referenceEncodingContextGame observer inputs hencoding dummy adversary := by
+  simp only [referenceGraphContextGame, referenceGraphContextRest, referenceEncodingContextGame, referenceEncodingContextRest,
+    map_bind, map_pure, bind_assoc, pure_bind]
+
+theorem referenceGraphContextGame_contact_event (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs) (dummy : OtsReferenceWords) (adversary : Adversary)
+    (event : InstrumentedResult ContactResult → Prop) :
+    Pr[fun result => event (result.1.parameter, result.2.2.1, result.2.2.2) |
+      referenceGraphContextGame contactObserver inputs hencoding dummy adversary] =
+        Pr[event | referenceContactGame inputs hencoding dummy adversary] := by
+  rw [referenceContactGame, ← referenceGraphContextGame_erased contactObserver inputs hencoding dummy adversary, probEvent_map]
+  rfl
+
+def GraphPrimitiveEvent (dummy : OtsReferenceWords) (result : GraphContextResult ContactResult) : Prop :=
+  let words := referenceFamilyWords result.2.2.1 dummy
+  let trace := result.2.2.2.before * result.2.2.2.after
+  OtsVerifierWitness.EncodingOutputMatch result.1.parameter words (canonicalGraphMessage result.2.1) result.2.2.1 trace ∨
+    ReferenceStructuralMatch.Seen result.1 result.2.1 words trace ∨
+      result.2.2.2.TwoEdge result.1.parameter words ∨ result.2.2.2.TwoContacts result.1.parameter words ∨
+        result.2.2.2.MarkerContact result.1.parameter words
+
+theorem graphPrimitiveEvent_of_outcome (key : SecretKey) (f : QueryImpl HashSpec Id) (selections : ReferenceFamily)
+    (dummy : OtsReferenceWords) (result : ContactResult)
+    (h : ReferencePrimitiveWitness.Outcome key f (referenceFamilyWords selections dummy)
+      (canonicalGraphMessage (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f)) selections result) :
+    GraphPrimitiveEvent dummy (key, canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f, selections, result) := by
+  rcases h with hencoding | hstructural | htwo | hdistinct | hmarker
+  · exact Or.inl hencoding
+  · exact Or.inr (Or.inl (ReferenceStructuralMatch.source_match key f _ _ hstructural))
+  · exact Or.inr (Or.inr (Or.inl htwo))
+  · exact Or.inr (Or.inr (Or.inr (Or.inl hdistinct)))
+  · exact Or.inr (Or.inr (Or.inr (Or.inr hmarker)))
+
+noncomputable def primitivePrefixRate (q : Nat) : ENNReal :=
+  let n : ENNReal := Fintype.card Digest
+  let x := (q : ENNReal) / n
+  prefixTwoEdgeRate q / (1 - x) + (4 * x) / ((1 - x)^2 * n) + (82 * x) / ((1 - x) * n)
+
+noncomputable def primitiveEncodingRate (q : Nat) : ENNReal :=
+  let n : ENNReal := Fintype.card Digest
+  let x := (q : ENNReal) / n
+  n⁻¹ + (3444 * x) / ((1 - x) * n)
+
+theorem primitivePrefixRate_mono {q r : Nat} (h : q ≤ r) : primitivePrefixRate q ≤ primitivePrefixRate r := by
+  dsimp only [primitivePrefixRate, prefixTwoEdgeRate]
+  gcongr
+
+theorem primitiveEncodingRate_mono {q r : Nat} (h : q ≤ r) : primitiveEncodingRate q ≤ primitiveEncodingRate r := by
+  dsimp only [primitiveEncodingRate]
+  gcongr
+
+theorem primitive_rates_small (q : Nat) (hq : q ≤ 3 * 2 ^ 114) :
+    primitivePrefixRate q ≤ (7 / 4 : ENNReal) / Fintype.card Digest ∧
+      primitiveEncodingRate q ≤ (7 / 4 : ENNReal) / Fintype.card Digest := by
+  have hcard : Fintype.card Digest = 2 ^ 128 := by simp [digestBits]
+  have hn : (Fintype.card Digest : ENNReal) ≠ 0 := by positivity
+  have hx : ((3 * 2 ^ 114 : Nat) : ENNReal) / Fintype.card Digest < 1 := by
+    rw [ENNReal.div_lt_iff (Or.inl hn) (Or.inl (by finiteness)), one_mul]
+    exact_mod_cast (show 3 * 2 ^ 114 < Fintype.card Digest by rw [hcard]; norm_num)
+  have hd : 1 - ((3 * 2 ^ 114 : Nat) : ENNReal) / Fintype.card Digest ≠ 0 := ne_of_gt (tsub_pos_iff_lt.mpr hx)
+  have hs := ENNReal.toReal_sub_of_le hx.le (show (1 : ENNReal) ≠ ⊤ by finiteness)
+  constructor
+  · apply (primitivePrefixRate_mono hq).trans
+    dsimp only [primitivePrefixRate, prefixTwoEdgeRate]
+    apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp
+    repeat rw [ENNReal.toReal_add (by finiteness) (by finiteness)]
+    simp only [ENNReal.toReal_mul, ENNReal.toReal_div, ENNReal.toReal_pow, hs,
+      ENNReal.toReal_natCast, ENNReal.toReal_ofNat, ENNReal.toReal_one]
+    repeat rw [ENNReal.toReal_add (by finiteness) (by finiteness)]
+    norm_num [ENNReal.toReal_mul, ENNReal.toReal_div, ENNReal.toReal_pow, hcard]
+  · apply (primitiveEncodingRate_mono hq).trans
+    dsimp only [primitiveEncodingRate]
+    apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp
+    repeat rw [ENNReal.toReal_add (by finiteness) (by finiteness)]
+    simp only [ENNReal.toReal_mul, ENNReal.toReal_div, ENNReal.toReal_inv, hs,
+      ENNReal.toReal_natCast, ENNReal.toReal_ofNat, ENNReal.toReal_one]
+    norm_num [hcard]
+
+theorem referenceGraphContextGame_primitive_le (dummy : OtsReferenceWords) (adversary : Adversary) (q : Nat)
+    (hbound : HasHashQueryBound scheme adversary q) (hsmall : q < Fintype.card Digest) :
+    Pr[GraphPrimitiveEvent dummy | referenceGraphContextGame contactObserver (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] ≤
+      primitivePrefixRate q * (∑' result,
+        Pr[= result | referenceRecordedGame (canonicalGraphGameInputs adversary)
+          (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] * (result.prefixCalls dummy : ENNReal)) +
+      primitiveEncodingRate q * (∑' result,
+        Pr[= result | referenceRecordedGame (canonicalGraphGameInputs adversary)
+          (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] * (result.encodingCalls : ENNReal)) +
+      (Fintype.card Digest : ENNReal)⁻¹ * (∑' result,
+        Pr[= result | referenceRecordedGame (canonicalGraphGameInputs adversary)
+          (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] * (result.otherCalls dummy : ENNReal)) := by
+  let law := referenceGraphContextGame contactObserver (canonicalGraphGameInputs adversary)
+    (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary
+  have he := referenceEncodingContextGame_match_le_encodingCost dummy adversary
+  rw [← referenceGraphContextGame_encoding contactObserver _ _ dummy adversary, probEvent_map] at he
+  have hs := referenceGraphContextGame_match_le_otherCost dummy adversary
+  have ht := referenceContactGame_twoEdge_le dummy adversary q hbound hsmall
+  have hd := referenceContactGame_distinct_le dummy adversary q hbound hsmall
+  have hm := referenceContactGame_markerContact_le dummy adversary q hbound hsmall
+  rw [← referenceGraphContextGame_contact_event _ _ dummy adversary] at ht hd hm
+  have h := (probEvent_or_le law _ _).trans (add_le_add he
+    ((probEvent_or_le law _ _).trans (add_le_add hs
+      ((probEvent_or_le law _ _).trans (add_le_add ht
+        ((probEvent_or_le law _ _).trans (add_le_add hd hm)))))))
+  change Pr[GraphPrimitiveEvent dummy | law] ≤ _ at h
+  refine h.trans_eq ?_
+  simp only [primitivePrefixRate, primitiveEncodingRate, div_eq_mul_inv]
+  ring
+
+theorem referenceGraphContextGame_primitive_joint_budget (dummy : OtsReferenceWords) (adversary : Adversary) (q : Nat)
+    (hbound : HasHashQueryBound scheme adversary q) (hsmall : q < Fintype.card Digest)
+    (rate : ENNReal) (hp : primitivePrefixRate q ≤ rate) (he : primitiveEncodingRate q ≤ rate)
+    (ho : (Fintype.card Digest : ENNReal)⁻¹ ≤ rate) :
+    Pr[GraphPrimitiveEvent dummy | referenceGraphContextGame contactObserver (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] +
+      rate * (∑' result, Pr[= result | referenceRecordedGame (canonicalGraphGameInputs adversary)
+        (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] * (result.messageCalls : ENNReal)) ≤ rate * q := by
+  let law := referenceRecordedGame (canonicalGraphGameInputs adversary)
+    (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary
+  have h := add_le_add (referenceGraphContextGame_primitive_le dummy adversary q hbound hsmall)
+    (le_refl (rate * ∑' result, Pr[= result | law] * (result.messageCalls : ENNReal)))
+  refine h.trans ?_
+  calc
+    _ ≤ rate * (∑' result, Pr[= result | law] * (result.prefixCalls dummy : ENNReal)) +
+        rate * (∑' result, Pr[= result | law] * (result.encodingCalls : ENNReal)) +
+        rate * (∑' result, Pr[= result | law] * (result.otherCalls dummy : ENNReal)) +
+        rate * (∑' result, Pr[= result | law] * (result.messageCalls : ENNReal)) :=
+      add_le_add (add_le_add (add_le_add (mul_le_mul' hp le_rfl) (mul_le_mul' he le_rfl)) (mul_le_mul' ho le_rfl)) le_rfl
+    _ = rate * ∑' result, Pr[= result | law] * ((result.prefixCalls dummy + result.remainingCalls dummy : Nat) : ENNReal) := by
+      simp only [ReferenceRecordedResult.remainingCalls, Nat.cast_add, mul_add, ENNReal.tsum_add, add_assoc]
+    _ ≤ rate * q := by
+      apply mul_le_mul' le_rfl
+      calc
+        _ ≤ ∑' result, Pr[= result | law] * (q : ENNReal) := by
+          apply ENNReal.tsum_le_tsum
+          intro result
+          by_cases hr : result ∈ support law
+          · exact mul_le_mul' le_rfl (Nat.cast_le.mpr (referenceRecordedGame_joint_budget dummy adversary q hbound result hr))
+          · rw [probOutput_eq_zero_of_not_mem_support hr, zero_mul, zero_mul]
+        _ ≤ q := by
+          rw [ENNReal.tsum_mul_right]
+          exact mul_le_of_le_one_left' tsum_probOutput_le_one
+
+theorem referenceGraphContextGame_primitive_small_budget (dummy : OtsReferenceWords) (adversary : Adversary) (q : Nat)
+    (hbound : HasHashQueryBound scheme adversary q) (hsmall : q ≤ 3 * 2 ^ 114) :
+    Pr[GraphPrimitiveEvent dummy | referenceGraphContextGame contactObserver (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] +
+      ((7 / 4 : ENNReal) / Fintype.card Digest) *
+        (∑' result, Pr[= result | referenceRecordedGame (canonicalGraphGameInputs adversary)
+          (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary] * (result.messageCalls : ENNReal)) ≤
+        (7 / 4 : ENNReal) * ((q : ENNReal) / Fintype.card Digest) := by
+  have hcard : Fintype.card Digest = 2 ^ 128 := by simp [digestBits]
+  have hq : q < Fintype.card Digest := hsmall.trans_lt (by rw [hcard]; norm_num)
+  have hr := primitive_rates_small q hsmall
+  have ho : (Fintype.card Digest : ENNReal)⁻¹ ≤ (7 / 4 : ENNReal) / Fintype.card Digest := by
+    apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp
+    norm_num [ENNReal.toReal_inv, ENNReal.toReal_div, hcard]
+  simpa only [div_eq_mul_inv, mul_right_comm, mul_assoc] using
+    referenceGraphContextGame_primitive_joint_budget dummy adversary q hbound hq _ hr.1 hr.2 ho
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/ReferencePrimitiveWitness.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferencePrimitiveWitness.lean
new file mode 100644
index 000000000..88dbff383
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferencePrimitiveWitness.lean
@@ -0,0 +1,66 @@
+import SphincsSecurity.Proof.Ots.VerifierContactWitness
+import SphincsSecurity.Proof.Reference.ReferenceVerifierInstantiation
+namespace SphincsSecurity.Concrete.ReferencePrimitiveWitness
+
+open _root_.OracleComp OracleSpec OtsContactTrace OtsVerifierWitness
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalGraphInputs canonicalEncodingInputs canonicalPayloadInputs instFintypePosition frontierRoot chainWalk
+
+def AboveFrontier (words : OtsReferenceWords) : Position → Prop
+  | .chain lay tree leaf chain step => (words lay tree leaf chain).val ≤ step.val
+  | _ => True
+
+def StructuralMatch (key : SecretKey) (f : QueryImpl HashSpec Id) (words : OtsReferenceWords) (trace : Trace) : Prop :=
+  ∃ position, AboveFrontier words position ∧ QueriedOutputMatch f key position trace
+
+def Outcome (key : SecretKey) (f : QueryImpl HashSpec Id) (words : OtsReferenceWords)
+    (messages : EncodingPosition → Digest) (selections : ReferenceFamily) (result : ContactResult) : Prop :=
+  EncodingOutputMatch key.parameter words messages selections (result.before * result.after) ∨
+    StructuralMatch key f words (result.before * result.after) ∨ result.TwoEdge key.parameter words ∨
+      result.TwoContacts key.parameter words ∨ result.MarkerContact key.parameter words
+
+theorem tree_match (key : SecretKey) (f : QueryImpl HashSpec Id) (words : OtsReferenceWords) (lay : Layer) (tree : TreeIndex) (trace : Trace)
+    (h : TreeOutputMatch f key.parameter lay tree (key.otsSecret lay tree) trace) : StructuralMatch key f words trace := by
+  obtain ⟨level, index, payload, hp, hl, hi, hb, hrow, hhit⟩ := h
+  let position : Position := .node lay tree ⟨level, hl.trans_le (layerHeight_le lay)⟩ ⟨index, hi⟩
+  refine ⟨position, trivial, hb, payload, hp, hrow, hhit.1, ?_⟩
+  simpa only [position, Position.domain, honestValue_node] using hhit.2
+
+theorem leaf_match (key : SecretKey) (f : QueryImpl HashSpec Id) (words : OtsReferenceWords)
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (trace : Trace)
+    (h : LeafOutputMatch f key.parameter lay tree leaf (key.otsSecret lay tree leaf) trace) : StructuralMatch key f words trace := by
+  obtain ⟨payload, hp, hne, hrow, hvalue⟩ := h
+  refine ⟨.leaf lay tree leaf, trivial, trivial, payload, hp, hrow, hne, ?_⟩
+  simpa only [Position.domain, honestValue_leaf, canonicalLeaf_eq_honestNode] using hvalue
+
+theorem forward_match (key : SecretKey) (f : QueryImpl HashSpec Id) (words : OtsReferenceWords)
+    (lay : Layer) (tree : TreeIndex) (leaf : LeafIndex) (chain : ChainIndex) (trace : Trace)
+    (h : ForwardChainMatch f (segment key.parameter words lay tree leaf chain) (key.otsSecret lay tree leaf chain) trace) :
+    StructuralMatch key f words trace := by
+  obtain ⟨step, payload, habove, hrow, hhit⟩ := h
+  refine ⟨.chain lay tree leaf chain step, habove, trivial, digestBytes payload, digestBytes_mem_canonicalPayloadInputs _, hrow, ?_, ?_⟩
+  · exact fun he => hhit.1 (digestBytes_injective he)
+  · simpa only [Position.domain, honestValue_chain] using hhit.2
+
+theorem fts_exception (key : SecretKey) (f : QueryImpl HashSpec Id) (words : OtsReferenceWords) (index : Index) (trace : Trace)
+    (h : FtsVerifierWitness.Exception f key index trace) : StructuralMatch key f words trace := by
+  obtain ⟨position, hp, hmatch⟩ := h
+  refine ⟨position, ?_, hmatch⟩
+  cases position <;> simp_all only [FtsVerifierWitness.AtIndex, AboveFrontier]
+
+theorem layer_exception (key : SecretKey) (f : QueryImpl HashSpec Id) (words : OtsReferenceWords)
+    (messages : EncodingPosition → Digest) (selections : ReferenceFamily) (result : ContactResult)
+    (hfrontier : ∀ lay tree leaf chain, result.frontier lay tree leaf chain = frontier f key.parameter words lay tree leaf (key.otsSecret lay tree leaf) chain)
+    (h : LayerException f key words messages selections (result.before * result.after)) : Outcome key f words messages selections result := by
+  rcases h with hencoding | ⟨lay, tree, leaf, htree | hleaf | hchain⟩
+  · exact Or.inl hencoding
+  · exact Or.inr (Or.inl (tree_match key f words lay tree _ htree))
+  · exact Or.inr (Or.inl (leaf_match key f words lay tree leaf _ hleaf))
+  · rcases chainException_contactResult f key.parameter words lay tree leaf (key.otsSecret lay tree leaf) result
+      (hfrontier lay tree leaf) hchain with ⟨chain, hforward⟩ | htwo | hcontacts | hmarker
+    · exact Or.inr (Or.inl (forward_match key f words lay tree leaf chain _ hforward))
+    · exact Or.inr (Or.inr (Or.inl htwo))
+    · exact Or.inr (Or.inr (Or.inr (Or.inl hcontacts)))
+    · exact Or.inr (Or.inr (Or.inr (Or.inr hmarker)))
+
+end SphincsSecurity.Concrete.ReferencePrimitiveWitness
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceQueryAllocation.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceQueryAllocation.lean
new file mode 100644
index 000000000..6404119ef
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceQueryAllocation.lean
@@ -0,0 +1,62 @@
+import SphincsSecurity.Proof.Reference.QueryClassAllocation
+import SphincsSecurity.Proof.Ots.OtsPrefixIdealAllocation
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalGraphInputs canonicalEncodingInputs canonicalGraphGameInputs
+
+theorem referenceRecordedRest_nonmessage_le (key : SecretKey) (f : QueryImpl HashSpec Id)
+    (labels : CanonicalGraphLabels) (selections : ReferenceFamily) (dummy : OtsReferenceWords) (adversary : Adversary)
+    (result : (Bool × SigningBoundaryTrace) × List OracleWorld.Domain)
+    (hresult : result ∈ support (referenceRecordedRest key f labels selections dummy adversary)) :
+    QueryCap.calls (CausalFrontierProgram.NonmessageHash key.parameter) result.2 + result.1.2.messageCalls.length ≤
+      result.1.2.hashCalls :=
+  CausalFrontierProgram.game_nonmessage_recorded_le _ _ _ _ _ _ result (QueryCap.simulate_oracle_mem_support _ _ result hresult)
+
+private theorem probComp_mem_of_evalDist {Result : Type} (computation : ProbComp Result) (result : Result)
+    (hresult : result ∈ support 𝒟[computation]) : result ∈ support computation :=
+  (mem_support_iff_of_evalDist_eq (mx := computation) (mx' := 𝒟[computation]) rfl result).mpr hresult
+
+theorem referenceRecordedGame_nonmessage_le (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) (result : ReferenceRecordedResult)
+    (hresult : result ∈ support (referenceRecordedGame inputs hencoding dummy adversary)) :
+    QueryCap.calls (CausalFrontierProgram.NonmessageHash result.1) result.2.2.2 + result.2.2.1.2.messageCalls.length ≤
+      result.2.2.1.2.hashCalls := by
+  simp only [referenceRecordedGame, mem_support_bind_iff] at hresult
+  obtain ⟨parameter, _, otsSecret, _, ftsSecret, _, reference, _, output, houtput, hresult⟩ := hresult
+  rw [mem_support_pure_iff] at hresult
+  subst result
+  exact referenceRecordedRest_nonmessage_le ⟨parameter, 0, otsSecret, ftsSecret⟩ (finiteHashAnswer ∅ inputs reference.2)
+    (canonicalGraphLabels parameter otsSecret ftsSecret (finiteHashAnswer ∅ inputs reference.2)) reference.1 dummy adversary output
+    (probComp_mem_of_evalDist _ output houtput)
+
+noncomputable def ReferenceRecordedResult.prefixCalls (dummy : OtsReferenceWords) (result : ReferenceRecordedResult) : Nat :=
+  ∑ address : OtsPrefix.ChainAddress,
+    QueryCap.calls (OtsPrefix.atAddress result.1 (referenceFamilyWords result.2.1 dummy) address).Selects result.2.2.2
+
+noncomputable def ReferenceRecordedResult.encodingCalls (result : ReferenceRecordedResult) : Nat :=
+  QueryCap.calls (QueryClass.EncodingHash result.1) result.2.2.2
+
+noncomputable def ReferenceRecordedResult.otherCalls (dummy : OtsReferenceWords) (result : ReferenceRecordedResult) : Nat :=
+  QueryCap.calls (QueryClass.OtherHash result.1 (referenceFamilyWords result.2.1 dummy)) result.2.2.2
+
+def ReferenceRecordedResult.messageCalls (result : ReferenceRecordedResult) : Nat := result.2.2.1.2.messageCalls.length
+
+noncomputable def ReferenceRecordedResult.remainingCalls (dummy : OtsReferenceWords) (result : ReferenceRecordedResult) : Nat :=
+  result.encodingCalls + result.otherCalls dummy + result.messageCalls
+
+theorem referenceRecordedGame_joint_budget (dummy : OtsReferenceWords) (adversary : Adversary) (q : Nat)
+    (hbound : HasHashQueryBound scheme adversary q) (result : ReferenceRecordedResult)
+    (hresult : result ∈ support (referenceRecordedGame (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary)) :
+    result.prefixCalls dummy + result.remainingCalls dummy ≤ q := by
+  have hpartition := QueryClass.allocation_calls result.1 (referenceFamilyWords result.2.1 dummy) result.2.2.2
+  have hslots := referenceRecordedGame_nonmessage_le _ _ dummy adversary result hresult
+  have hbudget := referenceRecordedGame_hashCalls_le dummy adversary q hbound result hresult
+  dsimp only [ReferenceRecordedResult.prefixCalls, ReferenceRecordedResult.remainingCalls,
+    ReferenceRecordedResult.encodingCalls, ReferenceRecordedResult.otherCalls, ReferenceRecordedResult.messageCalls]
+  omega
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceResidualGame.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceResidualGame.lean
new file mode 100644
index 000000000..802243c5c
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceResidualGame.lean
@@ -0,0 +1,67 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Ots.ReferenceFamilyGame
+import SphincsSecurity.Proof.Reference.ReferenceResidualSampling
+import SphincsSecurity.Proof.Residual.ResidualGraphGame
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def referenceResidualGame (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) : SPMF (ReferenceFamily × (Bool × SigningBoundaryTrace)) := do
+  let parameter ← 𝒟[sampleParameter]
+  let otsSecret ← 𝒟[sampleOtsSecrets]
+  let ftsSecret ← 𝒟[sampleFtsSecrets]
+  let key : SecretKey := ⟨parameter, 0, otsSecret, ftsSecret⟩
+  let sampled ← 𝒟[graphReferenceSample parameter inputs (hencoding parameter)]
+  let f := programmedHash parameter otsSecret ftsSecret sampled.2.1 (finiteHashAnswer ∅ inputs sampled.2.2)
+  let result ← 𝒟[referenceFamilyFrontierRest key f sampled.2.1 sampled.1 dummy adversary]
+  pure (sampled.1, result)
+
+theorem referenceResidualGame_erased (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    Prod.snd <$> referenceResidualGame inputs hencoding dummy adversary =
+      𝒟[residualGraphOracleGame inputs dummy adversary] := by
+  rw [referenceResidualGame, residualGraphOracleGame]
+  simp only [map_bind, map_pure, bind_pure, evalDist_bind]
+  apply congrArg (𝒟[sampleParameter] >>= ·)
+  funext parameter
+  apply congrArg (𝒟[sampleOtsSecrets] >>= ·)
+  funext otsSecret
+  apply congrArg (𝒟[sampleFtsSecrets] >>= ·)
+  funext ftsSecret
+  have h := graphReferenceSample_bind_selected ⟨parameter, 0, otsSecret, ftsSecret⟩ inputs (hencoding parameter)
+    (fun selections labels residual => referenceFamilyFrontierRest ⟨parameter, 0, otsSecret, ftsSecret⟩
+      (programmedHash parameter otsSecret ftsSecret labels (finiteHashAnswer ∅ inputs residual)) labels selections dummy adversary)
+  simpa only [referenceFamilyFrontierRest_selected, evalDist_bind] using h
+
+theorem evalDist_boundaryGameCore_referenceResidual (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary)
+    (hinputs : hashInputs (boundaryGameCore adversary) ⊆ inputs) :
+    𝒟[(simulateQ romImpl (boundaryGameCore adversary)).run' ∅] =
+      Prod.snd <$> referenceResidualGame inputs hencoding dummy adversary := by
+  rw [referenceResidualGame_erased]
+  exact evalDist_boundaryGameCore_residualGraph inputs hgraph dummy adversary hinputs
+
+theorem referenceResidualGame_hashCalls_le (dummy : OtsReferenceWords) (adversary : Adversary)
+    (q : Nat) (hbound : HasHashQueryBound scheme adversary q) (result : ReferenceFamily × (Bool × SigningBoundaryTrace))
+    (hresult : result ∈ support (referenceResidualGame (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary)) :
+    result.2.2.hashCalls ≤ q := by
+  apply boundaryGameCore_hashCalls_le adversary q hbound result.2
+  apply (mem_support_iff_of_evalDist_eq
+    (mx' := Prod.snd <$> referenceResidualGame (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary) dummy adversary)
+    (evalDist_boundaryGameCore_referenceResidual (canonicalGraphGameInputs adversary)
+      (canonicalEncodingInputs_subset_gameInputs adversary)
+      (canonicalGraphInputs_subset_gameInputs adversary) dummy adversary
+      (hashInputs_subset_canonicalGraphGameInputs adversary)) result.2).mpr
+  rw [support_map]
+  exact ⟨result, hresult, rfl⟩
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceResidualSampling.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceResidualSampling.lean
new file mode 100644
index 000000000..981bce6f1
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceResidualSampling.lean
@@ -0,0 +1,110 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.CanonicalResidualQuery
+import SphincsSecurity.Proof.Ots.EncodingFamilyOracleSplit
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+theorem readCanonicalEncodingRows_programmedHash (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (labels encodingLabels : CanonicalGraphLabels)
+    (residual : QueryImpl HashSpec Id) :
+    readCanonicalEncodingRows parameter encodingLabels (programmedHash parameter otsSecret ftsSecret labels residual) =
+      readCanonicalEncodingRows parameter encodingLabels residual := by
+  funext row
+  apply programmedHash_other
+  intro position heq
+  have hencoding : AtEncodingPosition parameter (canonicalEncodingRowInput parameter encodingLabels row) row.1 := ⟨_, rfl⟩
+  exact hencoding.not_atPosition position ⟨_, heq⟩
+
+theorem referenceTableSelection_programmedHash (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (residual : inputs → HashOutput) (position : EncodingPosition) :
+    referenceTableSelection key
+      (programmedHash key.parameter key.otsSecret key.ftsSecret labels (finiteHashAnswer ∅ inputs residual)) position =
+      FirstSuccessTable.select decodeEncodingOutput
+        (fun counter => residual (canonicalEncodingCell key.parameter inputs hencoding labels (position, counter))) := by
+  rw [referenceTableSelection, canonicalGraphLabels_programmedHash, readCanonicalEncodingRows_programmedHash,
+    readCanonicalEncodingRows_finite key.parameter inputs hencoding]
+  rfl
+
+noncomputable def residualReferenceSample (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (labels : CanonicalGraphLabels) :
+    PMF (ReferenceFamily × (inputs → HashOutput)) :=
+  (FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit).bind (fun selections =>
+    (FirstSuccessFamily.afterSelect decodeEncodingOutput encodingAttemptLimit decodeEncodingOutput_invalid_nonempty selections).bind
+      (fun rows => (PMF.uniformOfFintype (UniformTableSplit.Outside (canonicalEncodingCell parameter inputs hencoding labels) → HashOutput)).map
+        (fun remaining => (selections, UniformTableSplit.join (canonicalEncodingCell parameter inputs hencoding labels)
+          (canonicalEncodingCell_injective parameter inputs hencoding labels) (Function.uncurry rows) remaining))))
+
+theorem uniform_joint_residualReference (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (labels : CanonicalGraphLabels) :
+    (PMF.uniformOfFintype (inputs → HashOutput)).map (fun residual =>
+      (referenceTableSelection key
+        (programmedHash key.parameter key.otsSecret key.ftsSecret labels (finiteHashAnswer ∅ inputs residual)), residual)) =
+      residualReferenceSample key.parameter inputs hencoding labels := by
+  have hselection (residual : inputs → HashOutput) :
+      referenceTableSelection key
+        (programmedHash key.parameter key.otsSecret key.ftsSecret labels (finiteHashAnswer ∅ inputs residual)) =
+      fun position => FirstSuccessTable.select decodeEncodingOutput
+        (fun counter => residual (canonicalEncodingCell key.parameter inputs hencoding labels (position, counter))) := by
+    funext position
+    exact referenceTableSelection_programmedHash key inputs hencoding labels residual position
+  have h := UniformTableSplit.uniform_bind_firstSuccessFamily
+    (canonicalEncodingCell key.parameter inputs hencoding labels)
+    (canonicalEncodingCell_injective key.parameter inputs hencoding labels)
+    decodeEncodingOutput decodeEncodingOutput_invalid_nonempty (fun selections residual => PMF.pure (selections, residual))
+  simpa only [hselection, residualReferenceSample, PMF.map, Function.comp_def] using h
+
+noncomputable def graphReferenceSample (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) :
+    PMF (ReferenceFamily × (CanonicalGraphLabels × (inputs → HashOutput))) :=
+  (FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit).bind (fun selections =>
+    (PMF.uniformOfFintype CanonicalGraphLabels).bind (fun labels =>
+      (FirstSuccessFamily.afterSelect decodeEncodingOutput encodingAttemptLimit decodeEncodingOutput_invalid_nonempty selections).bind
+        (fun rows => (PMF.uniformOfFintype (UniformTableSplit.Outside (canonicalEncodingCell parameter inputs hencoding labels) → HashOutput)).map
+          (fun remaining => (selections, (labels, UniformTableSplit.join (canonicalEncodingCell parameter inputs hencoding labels)
+            (canonicalEncodingCell_injective parameter inputs hencoding labels) (Function.uncurry rows) remaining))))))
+
+theorem uniformGraph_bind_residualReference (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) :
+    (PMF.uniformOfFintype CanonicalGraphLabels).bind (fun labels =>
+      (residualReferenceSample parameter inputs hencoding labels).map (fun result => (result.1, (labels, result.2)))) =
+      graphReferenceSample parameter inputs hencoding := by
+  simp only [residualReferenceSample, graphReferenceSample, PMF.map_bind, PMF.map_comp, Function.comp_def]
+  rw [PMF.bind_comm]
+
+theorem uniform_joint_graphReference (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) :
+    (PMF.uniformOfFintype CanonicalGraphLabels).bind (fun labels =>
+      (PMF.uniformOfFintype (inputs → HashOutput)).map (fun residual =>
+        (referenceTableSelection key
+          (programmedHash key.parameter key.otsSecret key.ftsSecret labels (finiteHashAnswer ∅ inputs residual)), (labels, residual)))) =
+      graphReferenceSample key.parameter inputs hencoding := by
+  rw [← uniformGraph_bind_residualReference]
+  apply congrArg (PMF.uniformOfFintype CanonicalGraphLabels).bind
+  funext labels
+  rw [← uniform_joint_residualReference key inputs hencoding labels, PMF.map_comp]
+  rfl
+
+noncomputable local instance referenceResidualLabelsSampleable : SampleableType CanonicalGraphLabels := SampleableType.ofFintype CanonicalGraphLabels
+noncomputable local instance referenceResidualTableSampleable (inputs : Finset HashInput) : SampleableType (inputs → HashOutput) :=
+  SampleableType.ofFintype (inputs → HashOutput)
+
+theorem graphReferenceSample_bind_selected {Result : Type} (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+    (next : ReferenceFamily → CanonicalGraphLabels → (inputs → HashOutput) → ProbComp Result) :
+    (𝒟[graphReferenceSample key.parameter inputs hencoding] >>= fun result => 𝒟[next result.1 result.2.1 result.2.2]) =
+      𝒟[do
+        let labels ← ($ᵗ CanonicalGraphLabels : ProbComp _)
+        let residual ← sampleHashTable inputs
+        next (referenceTableSelection key
+          (programmedHash key.parameter key.otsSecret key.ftsSecret labels (finiteHashAnswer ∅ inputs residual))) labels residual] := by
+  rw [← uniform_joint_graphReference key inputs hencoding]
+  simp only [← PMF.monad_map_eq_map, ← PMF.monad_bind_eq_bind, map_eq_bind_pure_comp, bind_assoc, pure_bind,
+    evalDist_bind, evalDist_pure, Function.comp_apply, sampleHashTable, evalDist_uniformSample]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceResidualSeeds.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceResidualSeeds.lean
new file mode 100644
index 000000000..5b90bda45
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceResidualSeeds.lean
@@ -0,0 +1,66 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.PublicReferenceResidual
+import SphincsSecurity.Proof.Reference.ReferenceResidualGame
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+structure ReferenceAuxiliary (inputs : Finset HashInput) where
+  selections : ReferenceFamily
+  rows : CanonicalEncodingRows
+  seed : inputs → HashOutput
+
+noncomputable def referenceAuxiliarySample (inputs : Finset HashInput) : PMF (ReferenceAuxiliary inputs) :=
+  (FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit).bind (fun selections =>
+    (FirstSuccessFamily.afterSelect decodeEncodingOutput encodingAttemptLimit decodeEncodingOutput_invalid_nonempty selections).bind
+      (fun rows => (PMF.uniformOfFintype (inputs → HashOutput)).map
+        (fun seed => ⟨selections, Function.uncurry rows, seed⟩)))
+
+theorem graphReferenceSample_eq_auxiliary (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) :
+    graphReferenceSample parameter inputs hencoding =
+      (referenceAuxiliarySample inputs).bind (fun auxiliary =>
+        (PMF.uniformOfFintype CanonicalGraphLabels).map (fun labels =>
+          (auxiliary.selections, (labels, canonicalReferenceResidual parameter inputs hencoding labels auxiliary.rows auxiliary.seed)))) := by
+  have hseed (selections : ReferenceFamily) (labels : CanonicalGraphLabels)
+      (rows : EncodingPosition → Fin encodingAttemptLimit → HashOutput) :
+      (PMF.uniformOfFintype (UniformTableSplit.Outside (canonicalEncodingCell parameter inputs hencoding labels) → HashOutput)).map
+          (fun remaining => (selections, (labels, UniformTableSplit.join (canonicalEncodingCell parameter inputs hencoding labels)
+            (canonicalEncodingCell_injective parameter inputs hencoding labels) (Function.uncurry rows) remaining))) =
+        (PMF.uniformOfFintype (inputs → HashOutput)).map (fun seed =>
+          (selections, (labels, canonicalReferenceResidual parameter inputs hencoding labels (Function.uncurry rows) seed))) := by
+    have h := congrArg (fun law : PMF (inputs → HashOutput) => law.map (fun table => (selections, (labels, table))))
+      (UniformTableSplit.uniform_overwrite (canonicalEncodingCell parameter inputs hencoding labels)
+        (canonicalEncodingCell_injective parameter inputs hencoding labels) (Function.uncurry rows))
+    simpa only [PMF.map_comp, Function.comp_def, canonicalReferenceResidual] using h.symm
+  unfold graphReferenceSample referenceAuxiliarySample
+  simp only [hseed, PMF.bind_bind, PMF.bind_map, Function.comp_def]
+  apply congrArg (FirstSuccessFamily.selected decodeEncodingOutput encodingAttemptLimit).bind
+  funext selections
+  rw [PMF.bind_comm]
+  apply congrArg (FirstSuccessFamily.afterSelect decodeEncodingOutput encodingAttemptLimit
+    decodeEncodingOutput_invalid_nonempty selections).bind
+  funext rows
+  simp only [PMF.map, Function.comp_def]
+  rw [PMF.bind_comm]
+
+theorem referenceResidualGame_eq_auxiliary (inputs : Finset HashInput)
+    (hencoding : ∀ parameter, canonicalEncodingInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    referenceResidualGame inputs hencoding dummy adversary = (do
+      let parameter ← 𝒟[sampleParameter]
+      let otsSecret ← 𝒟[sampleOtsSecrets]
+      let ftsSecret ← 𝒟[sampleFtsSecrets]
+      let auxiliary ← 𝒟[referenceAuxiliarySample inputs]
+      let labels ← 𝒟[PMF.uniformOfFintype CanonicalGraphLabels]
+      let f := programmedHash parameter otsSecret ftsSecret labels
+        (finiteHashAnswer ∅ inputs (canonicalReferenceResidual parameter inputs (hencoding parameter) labels auxiliary.rows auxiliary.seed))
+      let result ← 𝒟[referenceFamilyFrontierRest ⟨parameter, 0, otsSecret, ftsSecret⟩ f labels auxiliary.selections dummy adversary]
+      pure (auxiliary.selections, result)) := by
+  simp only [referenceResidualGame, graphReferenceSample_eq_auxiliary,
+    ← PMF.monad_bind_eq_bind, ← PMF.monad_map_eq_map, evalDist_bind, evalDist_map, bind_assoc, bind_map_left]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceSigningReplay.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceSigningReplay.lean
new file mode 100644
index 000000000..2c38384a7
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceSigningReplay.lean
@@ -0,0 +1,103 @@
+import SphincsSecurity.Proof.Reference.VerifierWitnessClassification
+import SphincsSecurity.Proof.Hypertree.PublicGraphSigner
+namespace SphincsSecurity.Concrete.OtsVerifierWitness
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition signAfterDigest sequenceFin chainWalk
+set_option backward.isDefEq.respectTransparency false
+
+theorem known_honest_public_plan (key : SecretKey) (f : QueryImpl HashSpec Id) (words : OtsReferenceWords) (selections : ReferenceFamily)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels)
+    (hagrees : PublicAgreement words disclosed known
+      (CanonicalCoordinate.value key.otsSecret key.ftsSecret (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f)))
+    (cache : QueryCache HashSpec) (index : Index) (leaves : IndexGroup → FtsLeaf) (signature : Signature)
+    (hfull : FullyHonestOpening f cache key index leaves signature)
+    (hreference : ∀ lay, ReferenceLayerOpening f key words selections index signature lay) :
+    (publicSignPlan known words selections signature.randomness index leaves).1.map
+      (fun plan => plan.finish (fun tree => key.ftsSecret index tree (leaves (ftsIndexOf tree)))) = some signature := by
+  have hfrontier := knownFrontier_eq key.otsSecret key.ftsSecret _ words disclosed known hagrees
+  rw [canonicalGraphLabels_frontier key.parameter key.otsSecret key.ftsSecret f words key.root] at hfrontier
+  let parts : Layer → LayerPart := fun lay => (signature.counter lay, signature.chainValue lay,
+    knownTreePath known lay (treeIndexAt index lay) (leafIndexAt index lay))
+  have hlayers : ∀ lay, (publicSignLayer known words selections index lay).1 = some (parts lay) := by
+    intro lay
+    obtain ⟨selected, hselected, hcounter, _, hvalues, _⟩ := hreference lay
+    have hchain : knownFrontier known words lay (treeIndexAt index lay) (leafIndexAt index lay) = signature.chainValue lay := by
+      rw [hfrontier]
+      funext chain
+      exact (hvalues chain).symm
+    simp only [publicSignLayer, referenceSelectionResult, hselected, Option.map_some, hchain, ← hcounter, parts]
+  have hftsPath : knownFtsPath known index leaves = signature.ftsPath := by
+    rw [knownFtsPath_eq key.parameter key.otsSecret key.ftsSecret f words disclosed known hagrees]
+    funext tree level
+    simp only [ftsOpen, evalWithAnswerFn_sequenceFin]
+    exact ((hfull.2.1 tree).2 level.val level.isLt).symm
+  have hauthPath : flattenPaths (fun lay => (parts lay).2.2) = signature.authPath := by
+    funext position
+    obtain ⟨lay, level, hlevel, hposition⟩ := authPath_exhausted position
+    rw [flattenPaths_apply _ lay level hlevel position hposition.symm]
+    change knownTreePath known lay (treeIndexAt index lay) (leafIndexAt index lay) level = signature.authPath position
+    rw [knownTreePath_eq key.parameter key.otsSecret key.ftsSecret f words disclosed known hagrees]
+    simp only [treePath, evalWithAnswerFn_sequenceFin, if_pos hlevel]
+    obtain ⟨_, _, _, hpath⟩ := (hfull.1 lay).1
+    have hp := hpath level.val hlevel
+    have hsum : heightAbove lay + level.val < totalHeight := by rw [hposition]; exact position.isLt
+    simp only [signaturePath, dif_pos hsum] at hp
+    have hfin : (⟨heightAbove lay + level.val, hsum⟩ : PathIndex) = position := Fin.ext hposition
+    simpa only [hfin, honestNode] using hp.symm
+  simp only [publicSignPlan, hlayers, sequenceFin_some, Option.map_some, hftsPath, PublicSigningPlan.finish, parts]
+  congr 1
+  change Signature.mk signature.randomness (fun tree => key.ftsSecret index tree (leaves (ftsIndexOf tree)))
+    signature.ftsPath signature.counter signature.chainValue
+      (flattenPaths fun lay => knownTreePath known lay (treeIndexAt index lay) (leafIndexAt index lay)) = signature
+  have hsecrets : (fun tree => key.ftsSecret index tree (leaves (ftsIndexOf tree))) = signature.ftsSecret :=
+    funext fun tree => ((hfull.2.1 tree).1).symm
+  rw [hsecrets, hauthPath]
+
+theorem honest_signAfterDigest (key : SecretKey) (f : QueryImpl HashSpec Id) (dummy : OtsReferenceWords)
+    (cache : QueryCache HashSpec) (index : Index) (leaves : IndexGroup → FtsLeaf) (signature : Signature)
+    (hfull : FullyHonestOpening f cache key index leaves signature)
+    (hreference : ∀ lay, ReferenceLayerOpening f key (canonicalReferenceWords key f dummy) (referenceTableSelection key f) index signature lay) :
+    evalWithAnswerFn f (signAfterDigest key signature.randomness index leaves) = some signature := by
+  let known := CanonicalCoordinate.value key.otsSecret key.ftsSecret (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f)
+  have hagrees : PublicAgreement (canonicalReferenceWords key f dummy) (fun _ _ _ => False) known known := fun _ _ => rfl
+  have hp := known_honest_public_plan key f (canonicalReferenceWords key f dummy) (referenceTableSelection key f)
+    (fun _ _ _ => False) known hagrees cache index leaves signature hfull hreference
+  have he := congrArg Prod.fst (boundaryEval_signAfterDigest_public key f (fun _ _ _ => False) known dummy hagrees signature.randomness index leaves)
+  rw [boundaryEval_fst] at he
+  exact he.trans hp
+
+theorem honest_signature_eq (key : SecretKey) (f : QueryImpl HashSpec Id) (dummy : OtsReferenceWords)
+    (cache : QueryCache HashSpec) (index : Index) (leaves : IndexGroup → FtsLeaf) (signature signed : Signature)
+    (hfull : FullyHonestOpening f cache key index leaves signature)
+    (hreference : ∀ lay, ReferenceLayerOpening f key (canonicalReferenceWords key f dummy) (referenceTableSelection key f) index signature lay)
+    (hsigned : evalWithAnswerFn f (signAfterDigest key signed.randomness index leaves) = some signed)
+    (hrandomness : signed.randomness = signature.randomness) : signed = signature := by
+  rw [hrandomness, honest_signAfterDigest key f dummy cache index leaves signature hfull hreference] at hsigned
+  exact (Option.some.inj hsigned).symm
+
+theorem strong_signing_payload_ne (key : SecretKey) (f : QueryImpl HashSpec Id) (dummy : OtsReferenceWords)
+    (cache : QueryCache HashSpec) (log : QueryLog SigningSpec) (forgery : Forgery)
+    (hnew : ¬ SigningTranscript.Contains log forgery)
+    (hfull : let digest := truncateMessageDigest (f (tweakableHashInput key.parameter .message
+      (messageDigestPayload key.root forgery.message forgery.signature.randomness)))
+      FullyHonestOpening f cache key (digestIndex digest) (digestLeaves digest) forgery.signature)
+    (hreference : let digest := truncateMessageDigest (f (tweakableHashInput key.parameter .message
+      (messageDigestPayload key.root forgery.message forgery.signature.randomness)))
+      ∀ lay, ReferenceLayerOpening f key (canonicalReferenceWords key f dummy) (referenceTableSelection key f)
+        (digestIndex digest) forgery.signature lay)
+    (message : Message) (signature : Signature) (hentry : (⟨message, some signature⟩ : SigningEntry) ∈ log)
+    (hsigned : let digest := truncateMessageDigest (f (tweakableHashInput key.parameter .message
+      (messageDigestPayload key.root message signature.randomness)))
+      evalWithAnswerFn f (signAfterDigest key signature.randomness (digestIndex digest) (digestLeaves digest)) = some signature) :
+    messageDigestPayload key.root message signature.randomness ≠
+      messageDigestPayload key.root forgery.message forgery.signature.randomness := by
+  intro heq
+  obtain ⟨hmessage, hrandomness⟩ := messageDigestPayload_injective key.root heq
+  dsimp only at hsigned
+  rw [heq] at hsigned
+  have hsignature := honest_signature_eq key f dummy cache _ _ forgery.signature signature hfull hreference hsigned hrandomness
+  exact hnew ⟨⟨message, some signature⟩, hentry, hmessage, congrArg some hsignature⟩
+
+end SphincsSecurity.Concrete.OtsVerifierWitness
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceVerifierInstantiation.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceVerifierInstantiation.lean
new file mode 100644
index 000000000..086b55ddb
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/ReferenceVerifierInstantiation.lean
@@ -0,0 +1,103 @@
+import SphincsSecurity.Proof.Ots.EncodingMarkerBound
+import SphincsSecurity.Proof.Hypertree.FrontierSigningOrigin
+import SphincsSecurity.Proof.Reference.ReferenceSigningReplay
+namespace SphincsSecurity.Concrete.ReferenceVerifierWitness
+
+open _root_.OracleComp OracleSpec OtsContactTrace OtsVerifierWitness
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] frontierRoot canonicalGraphInputs canonicalEncodingInputs instFintypePosition chainWalk sequenceFin
+
+noncomputable abbrev rootedKey (key : SecretKey) (f : QueryImpl HashSpec Id) : SecretKey :=
+  { key with root := honestNode f key.parameter topLayer rootTree (key.otsSecret topLayer rootTree) (layerHeight topLayer) 0 }
+
+theorem source_root (key : SecretKey) (f : QueryImpl HashSpec Id) (words : OtsReferenceWords) :
+    frontierRoot key.parameter (maskOtsPrefixes key.parameter words f) words
+      (canonicalGraphFrontier key.otsSecret (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f) words) = (rootedKey key f).root := by
+  rw [← frontierRoot_eq_of_agree key.parameter words f (maskOtsPrefixes key.parameter words f) (maskOtsPrefixes_agrees key.parameter words f),
+    canonicalGraphLabels_frontier key.parameter key.otsSecret key.ftsSecret f words key.root,
+    frontierRoot_eq key f words _ (isSigningFrontier_canonical key f words)]
+  rfl
+
+theorem canonical_messages (key : SecretKey) (f : QueryImpl HashSpec Id) (root : Digest) (index : Index) (lay : Layer) :
+    canonicalGraphMessage (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f) ⟨lay, treeIndexAt index lay, leafIndexAt index lay⟩ =
+      evalWithAnswerFn f (layerMessage ({ key with root := root } : SecretKey) index lay) := by
+  change canonicalGraphMessage (canonicalGraphLabels ({ key with root := root } : SecretKey).parameter ({ key with root := root } : SecretKey).otsSecret ({ key with root := root } : SecretKey).ftsSecret f)
+    ⟨lay, treeIndexAt index lay, leafIndexAt index lay⟩ = _
+  rw [canonicalGraphMessage_eq ({ key with root := root } : SecretKey) f, layerMessage_referenceIndex]
+
+theorem referenceTableSelection_root (key : SecretKey) (f : QueryImpl HashSpec Id) (root : Digest) :
+    referenceTableSelection { key with root := root } f = referenceTableSelection key f := rfl
+
+theorem canonicalReferenceWords_root (key : SecretKey) (f : QueryImpl HashSpec Id) (root : Digest) (dummy : OtsReferenceWords) :
+    canonicalReferenceWords { key with root := root } f dummy = canonicalReferenceWords key f dummy := by
+  rw [← referenceFamilyWords_selected, referenceTableSelection_root, referenceFamilyWords_selected]
+
+def SuccessWitnessFor (key : SecretKey) (f : QueryImpl HashSpec Id) (root : Digest) (words : OtsReferenceWords)
+    (selections : ReferenceFamily) (adversary : Adversary) (result : ContactResult) (before : AdversaryTrace) : Prop :=
+  let actualKey : SecretKey := { key with root := root }
+  let labels := canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f
+  let frontier := canonicalGraphFrontier key.otsSecret labels words
+  let trace := result.before * result.after
+  before ∈ support (fixedTrace f (CausalFrontierProgram.adversaryRun key.parameter actualKey.root f key.ftsSecret words frontier
+    (adversary.main ⟨actualKey.root, key.parameter⟩))) ∧
+  SigningTranscript.Valid before.1.1.2 ∧ ¬SigningTranscript.Contains before.1.1.2 before.1.1.1 ∧
+  (∀ message signature, (⟨message, some signature⟩ : SigningEntry) ∈ before.1.1.2 →
+    ReferenceSigningWitness.SignatureOrigin actualKey f message signature before.1.2) ∧
+  result.frontier = frontier ∧
+  trace = before.2 * answerTrace f (verify ⟨actualKey.root, key.parameter⟩ before.1.1.1.message before.1.1.1.signature) ∧
+  ∃ digest, evalWithAnswerFn f (messageDigest key.parameter actualKey.root before.1.1.1.message before.1.1.1.signature.randomness) = digest ∧
+    ContainsRun f trace (messageDigest key.parameter actualKey.root before.1.1.1.message before.1.1.1.signature.randomness) ∧ Admissible digest ∧
+    ((FullyHonestOpening f (recordedCache f trace) actualKey (digestIndex digest) (digestLeaves digest) before.1.1.1.signature ∧
+      (∀ lay, ReferenceLayerOpening f actualKey words selections (digestIndex digest) before.1.1.1.signature lay) ∧
+      (∀ tree, FtsVerifierWitness.TrueSecretQuery f actualKey (digestIndex digest) tree (digestLeaves digest (ftsIndexOf tree)) trace) ∧
+      ∀ message signature, (⟨message, some signature⟩ : SigningEntry) ∈ before.1.1.2 →
+        messageDigestPayload actualKey.root message signature.randomness ≠
+          messageDigestPayload actualKey.root before.1.1.1.message before.1.1.1.signature.randomness) ∨
+      LayerException f actualKey words (canonicalGraphMessage labels) selections trace ∨ FtsVerifierWitness.Exception f actualKey (digestIndex digest) trace)
+
+theorem run_success_atRoot (key : SecretKey) (f : QueryImpl HashSpec Id) (root : Digest)
+    (hroot : root = honestNode f key.parameter topLayer rootTree (key.otsSecret topLayer rootTree) (layerHeight topLayer) 0)
+    (selections : ReferenceFamily) (dummy : OtsReferenceWords) (adversary : Adversary) (result : ContactResult)
+    (before : AdversaryTrace) (hselected : selections = referenceTableSelection key f)
+    (hvalid : ∀ lay tree leaf, TargetSum.Valid (referenceFamilyWords selections dummy lay tree leaf))
+    (hb : before ∈ support (fixedTrace f (CausalFrontierProgram.adversaryRun key.parameter root f key.ftsSecret
+      (referenceFamilyWords selections dummy)
+      (canonicalGraphFrontier key.otsSecret (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f) (referenceFamilyWords selections dummy))
+      (adversary.main ⟨root, key.parameter⟩))))
+    (hv : SigningTranscript.Valid before.1.1.2) (hf : ¬SigningTranscript.Contains before.1.1.2 before.1.1.1)
+    (hverify : evalWithAnswerFn f (verify ⟨root, key.parameter⟩ before.1.1.1.message before.1.1.1.signature) = true)
+    (hfrontier : result.frontier = canonicalGraphFrontier key.otsSecret
+      (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f) (referenceFamilyWords selections dummy))
+    (ht : result.before * result.after = before.2 * answerTrace f (verify ⟨root, key.parameter⟩ before.1.1.1.message before.1.1.1.signature)) :
+    SuccessWitnessFor key f root (referenceFamilyWords selections dummy) selections adversary result before := by
+  have hrun : ContainsRun f (result.before * result.after) (verify ⟨root, key.parameter⟩ before.1.1.1.message before.1.1.1.signature) := by
+    rw [ht]
+    exact (containsRun_answerTrace f _).mul_left before.2
+  have hw : referenceFamilyWords selections dummy = canonicalReferenceWords { key with root := root } f dummy := by
+    rw [hselected, referenceFamilyWords_selected]
+    exact (canonicalReferenceWords_root key f root dummy).symm
+  have hbc := hb
+  rw [canonicalGraphLabels_frontier key.parameter key.otsSecret key.ftsSecret f _ root, hw] at hbc
+  have horigin := ReferenceSigningWitness.fixedTrace_origin { key with root := root } f
+    (canonicalReferenceWords { key with root := root } f dummy) _
+    (isSigningFrontier_canonical { key with root := root } f _) (frontierReferenceWord_canonical { key with root := root } f dummy)
+    (adversary.main ⟨root, key.parameter⟩) before hbc
+  refine ⟨hb, hv, hf, horigin, hfrontier, ht, ?_⟩
+  obtain ⟨digest, hdigest, hdigestRun, hadmissible, hcases⟩ := verify_classification f { key with root := root } (referenceFamilyWords selections dummy)
+    (canonicalGraphMessage (canonicalGraphLabels key.parameter key.otsSecret key.ftsSecret f)) selections before.1.1.1.message before.1.1.1.signature
+    (result.before * result.after) hvalid (canonical_messages key f root) hroot hverify hrun
+  refine ⟨digest, hdigest, hdigestRun, hadmissible, ?_⟩
+  rcases hcases with ⟨hfull, href, hqueries⟩ | hbad
+  · refine Or.inl ⟨hfull, href, hqueries, ?_⟩
+    intro message signature hentry
+    have heval : evalWithAnswerFn f (messageDigest key.parameter root before.1.1.1.message before.1.1.1.signature.randomness) =
+        truncateMessageDigest (f (tweakableHashInput key.parameter .message
+          (messageDigestPayload root before.1.1.1.message before.1.1.1.signature.randomness))) := rfl
+    have hd := hdigest.symm.trans heval
+    rw [hd] at hfull href
+    rw [hw, hselected, ← referenceTableSelection_root key f root] at href
+    exact strong_signing_payload_ne { key with root := root } f dummy (recordedCache f (result.before * result.after))
+      before.1.1.2 before.1.1.1 hf hfull href message signature hentry (horigin message signature hentry).2.2
+  · exact Or.inr hbad
+
+end SphincsSecurity.Concrete.ReferenceVerifierWitness
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/SigningBoundaryHashCost.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/SigningBoundaryHashCost.lean
new file mode 100644
index 000000000..27a175133
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/SigningBoundaryHashCost.lean
@@ -0,0 +1,102 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Reference.BoundaryHashCost
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] BoundaryHashAtLeast signDigestLoop
+
+theorem boundaryHashAtLeast_lift_sequenceFin {α : Type} {n : Nat} (parameter : PublicParameter)
+    (computation : Fin n → OracleComp HashSpec α) (cost : Fin n → Nat)
+    (hcost : ∀ i, BoundaryHashAtLeast parameter (liftM (computation i)) (cost i)) :
+    BoundaryHashAtLeast parameter (liftM (sequenceFin computation)) (∑ i, cost i) := by
+  induction n with
+  | zero =>
+      rw [Fin.sum_univ_zero]
+      exact boundaryHashAtLeast_zero _ _
+  | succ n ih =>
+      rw [sequenceFin, liftM_bind, Fin.sum_univ_succ]
+      apply boundaryHashAtLeast_bind _ _ _ _ _ (hcost 0)
+      intro head
+      rw [liftM_bind, ← Nat.add_zero (∑ i : Fin n, cost i.succ)]
+      apply boundaryHashAtLeast_bind _ _ _ _ _ (ih _ _ (fun i => hcost i.succ))
+      intro tail
+      exact boundaryHashAtLeast_zero _ _
+
+theorem boundaryHashAtLeast_ftsNode (traceParameter parameter : PublicParameter) (index : Index) (tree : FtsTree)
+    (secret : FtsLeaf → Digest) (level nodeIdx : Nat) :
+    BoundaryHashAtLeast traceParameter
+      (liftM (ftsNode parameter index tree secret level nodeIdx : OracleComp HashSpec Digest))
+      (2 ^ (level + 1) - 1) := by
+  induction level generalizing nodeIdx with
+  | zero =>
+      rw [ftsNode_zero_eq]
+      exact boundaryHashAtLeast_tweakableHash traceParameter parameter
+        (.ftsLeaf index tree (ftsLeafOfNat nodeIdx)) (digestBytes (secret (ftsLeafOfNat nodeIdx)))
+  | succ level ih =>
+      rw [ftsNode_succ_eq, liftM_bind]
+      have hpower : 0 < 2 ^ (level + 1) := by positivity
+      have hcost : 2 ^ (level + 1 + 1) - 1 = (2 ^ (level + 1) - 1) + ((2 ^ (level + 1) - 1) + 1) := by
+        rw [pow_succ]
+        omega
+      rw [hcost]
+      apply boundaryHashAtLeast_bind _ _ _ _ _ (ih _)
+      intro left
+      rw [liftM_bind]
+      apply boundaryHashAtLeast_bind _ _ _ _ _ (ih _)
+      intro right
+      exact boundaryHashAtLeast_tweakableHash _ _ _ _
+
+theorem boundaryHashAtLeast_ftsOpen (traceParameter parameter : PublicParameter) (index : Index)
+    (leaves : IndexGroup → FtsLeaf) (secret : FtsTree → FtsLeaf → Digest) :
+    BoundaryHashAtLeast traceParameter (liftM (ftsOpen parameter index leaves secret : OracleComp HashSpec _))
+      (∑ _tree : FtsTree, ∑ level : Fin ftsTreeHeight, (2 ^ (level.val + 1) - 1)) := by
+  unfold ftsOpen
+  apply boundaryHashAtLeast_lift_sequenceFin
+  intro tree
+  apply boundaryHashAtLeast_lift_sequenceFin
+  intro level
+  exact boundaryHashAtLeast_ftsNode _ _ _ _ _ _ _
+
+theorem boundaryHashAtLeast_signAttempt (parameter : PublicParameter) (key : SecretKey)
+    (message : Message) (randomness : Randomness) :
+    BoundaryHashAtLeast parameter (liftM (signAttempt key message randomness : OracleComp HashSpec _)) 1 := by
+  unfold signAttempt messageDigest
+  rw [liftM_bind, liftM_bind, bind_assoc]
+  apply boundaryHashAtLeast_bind _ _ _ 1 0 (boundaryHashAtLeast_hash _ _)
+  intro output
+  exact boundaryHashAtLeast_zero _ _
+
+theorem boundaryHashAtLeast_signDigestLoop_bind {α : Type} (parameter : PublicParameter)
+    (key : SecretKey) (message : Message) (cost attempts : Nat)
+    (next : Option (Randomness × Index × (IndexGroup → FtsLeaf)) → OracleComp OracleWorld α)
+    (hnext : ∀ selected, BoundaryHashAtLeast parameter (next (some selected)) cost) :
+    BoundaryHashAtLeast parameter (signDigestLoop attempts key message >>= next) (min attempts cost) := by
+  induction attempts with
+  | zero => exact boundaryHashAtLeast_zero _ _
+  | succ attempts ih =>
+      rw [signDigestLoop, bind_assoc, ← Nat.zero_add (min (attempts + 1) cost)]
+      apply boundaryHashAtLeast_bind _ _ _ 0 _ (boundaryHashAtLeast_zero _ _)
+      intro randomness
+      rw [bind_assoc]
+      apply BoundaryHashAtLeast.mono (a := 1 + min attempts cost) ?_ (by omega)
+      apply boundaryHashAtLeast_bind _ _ _ 1 _ (boundaryHashAtLeast_signAttempt _ _ _ _)
+      intro attempt
+      cases attempt with
+      | none => exact ih
+      | some selected =>
+          simp only [pure_bind]
+          exact BoundaryHashAtLeast.mono (hnext _) (min_le_right _ _)
+
+theorem boundaryHashAtLeast_sign (parameter : PublicParameter) (key : SecretKey) (message : Message) :
+    BoundaryHashAtLeast parameter (sign key message) 28504 := by
+  rw [sign_eq]
+  apply BoundaryHashAtLeast.mono (a := min digestAttemptLimit 28504) ?_ (by decide)
+  apply boundaryHashAtLeast_signDigestLoop_bind
+  rintro ⟨randomness, index, leaves⟩
+  apply boundaryHashAtLeast_bind _ _ _ 28504 0
+  · exact BoundaryHashAtLeast.mono (boundaryHashAtLeast_ftsOpen _ _ _ _ _) (by decide)
+  · intro path
+    exact boundaryHashAtLeast_zero _ _
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/SigningTrace.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/SigningTrace.lean
new file mode 100644
index 000000000..0a2b62a8d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/SigningTrace.lean
@@ -0,0 +1,76 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Scheme.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
+
+def signingLogFragment
+    (input : (OracleWorld + SigningSpec).Domain)
+    (output : (OracleWorld + SigningSpec).Range input) : QueryLog SigningSpec :=
+  match input with
+  | .inl _ => []
+  | .inr request => [⟨request, output⟩]
+
+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
+
+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)
+
+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
+
+noncomputable def logTracedMappedAdversaryImpl (secretKey : SecretKey) :
+    QueryImpl (OracleWorld + SigningSpec)
+      (StateT (QueryCache HashSpec × QueryLog SigningSpec) ProbComp) :=
+  QueryImpl.extendState (unloggedMappedAdversaryImpl secretKey) signingLogUpdate
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/VerifierTraceDescent.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/VerifierTraceDescent.lean
new file mode 100644
index 000000000..ff0705d69
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/VerifierTraceDescent.lean
@@ -0,0 +1,22 @@
+import SphincsSecurity.Proof.Ots.OtsChainBackward
+namespace SphincsSecurity.Concrete.OtsContactTrace
+
+open _root_.OracleComp OracleSpec
+attribute [local instance] Classical.propDecidable
+
+noncomputable def recordedCache (f : QueryImpl HashSpec Id) (trace : Trace) : QueryCache HashSpec :=
+  fun input => if (input, f input) ∈ trace.toList then some (f input) else none
+
+theorem recordedCache_ne_none (f : QueryImpl HashSpec Id) (trace : Trace) (input : HashInput) :
+    recordedCache f trace input ≠ none ↔ (input, f input) ∈ trace.toList := by
+  by_cases h : (input, f input) ∈ trace.toList <;> simp only [recordedCache, h, ↓reduceIte, ne_eq, reduceCtorEq, not_false_eq_true, not_true_eq_false]
+
+theorem recordedCache_run_iff {Result : Type} (f : QueryImpl HashSpec Id) (trace : Trace) (computation : OracleComp HashSpec Result) :
+    CachedRun (recordedCache f trace) f computation ↔ ContainsRun f trace computation := by
+  simp only [CachedRun, ContainsRun, recordedCache_ne_none]
+
+theorem ContainsRun.cached {Result : Type} {f : QueryImpl HashSpec Id} {trace : Trace} {computation : OracleComp HashSpec Result}
+    (h : ContainsRun f trace computation) : CachedRun (recordedCache f trace) f computation :=
+  (recordedCache_run_iff f trace computation).mpr h
+
+end SphincsSecurity.Concrete.OtsContactTrace
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/VerifierTraceSource.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/VerifierTraceSource.lean
new file mode 100644
index 000000000..dbd90782b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/VerifierTraceSource.lean
@@ -0,0 +1,72 @@
+import SphincsSecurity.Proof.Reference.VerifierTraceDescent
+namespace SphincsSecurity.Concrete.OtsContactTrace
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def fixedTrace {Result : Type} (f : QueryImpl HashSpec Id) (computation : OracleComp OracleWorld Result) : ProbComp (Result × Trace) :=
+  simulateQ (fixedHashWorld f) (QueryPause.traced hashObservationTrace computation)
+
+theorem fixedTrace_forget {Result : Type} (f : QueryImpl HashSpec Id) (computation : OracleComp OracleWorld Result) :
+    Prod.fst <$> fixedTrace f computation = simulateQ (fixedHashWorld f) computation := by
+  rw [fixedTrace, ← simulateQ_map, QueryPause.traced_forget]
+
+theorem fixedTrace_pure {Result : Type} (f : QueryImpl HashSpec Id) (value : Result) :
+    fixedTrace f (pure value) = pure (value, 1) := by
+  simp only [fixedTrace, QueryPause.traced_pure, simulateQ_pure]
+
+theorem fixedTrace_bind {Result Next : Type} (f : QueryImpl HashSpec Id) (computation : OracleComp OracleWorld Result)
+    (next : Result → OracleComp OracleWorld Next) :
+    fixedTrace f (computation >>= next) = fixedTrace f computation >>= fun first =>
+      (fun second => (second.1, first.2 * second.2)) <$> fixedTrace f (next first.1) := by
+  simp only [fixedTrace, QueryPause.traced, simulateQ_bind, WriterT.run_bind, simulateQ_map]
+
+theorem fixedTrace_map {Result Next : Type} (f : QueryImpl HashSpec Id) (computation : OracleComp OracleWorld Result) (g : Result → Next) :
+    fixedTrace f (g <$> computation) = (fun result => (g result.1, result.2)) <$> fixedTrace f computation := by
+  simp only [fixedTrace, QueryPause.traced, simulateQ_map, WriterT.run_map]
+
+theorem fixedTrace_hash_query (f : QueryImpl HashSpec Id) (input : HashInput) :
+    fixedTrace f (liftM (OracleWorld.query (.inr input))) = pure (f input, FreeMonoid.of (input, f input)) := by
+  simp only [fixedTrace, QueryPause.traced, simulateQ_spec_query, QueryImpl.withTrace_apply,
+    QueryImpl.id'_apply, WriterT.run_bind, WriterT.run_tell, WriterT.run_monadLift, simulateQ_bind,
+    simulateQ_map, simulateQ_spec_query, fixedHashWorld, pure_bind, map_pure, one_mul, hashObservationTrace,
+    WriterT.run_pure, simulateQ_pure, mul_one]
+
+def answerTrace {Result : Type} (f : QueryImpl HashSpec Id) (computation : OracleComp HashSpec Result) : Trace :=
+  FreeMonoid.ofList ((queriedInputs f computation).map fun input => (input, f input))
+
+theorem containsRun_answerTrace {Result : Type} (f : QueryImpl HashSpec Id) (computation : OracleComp HashSpec Result) :
+    ContainsRun f (answerTrace f computation) computation := by
+  intro input hi
+  exact List.mem_map_of_mem (f := fun input => (input, f input)) hi
+
+private theorem boundaryComputation_bind {Result Next : Type} (parameter : PublicParameter) (computation : OracleComp OracleWorld Result)
+    (next : Result → OracleComp OracleWorld Next) :
+    boundaryComputation parameter (computation >>= next) = boundaryComputation parameter computation >>= fun first =>
+      (fun second => (second.1, first.2 * second.2)) <$> boundaryComputation parameter (next first.1) := by
+  simp only [boundaryComputation, simulateQ_bind, WriterT.run_bind]
+
+private theorem boundaryComputation_hash_query (parameter : PublicParameter) (input : HashInput) :
+    boundaryComputation parameter (liftM (OracleWorld.query (.inr input))) =
+      (fun answer => (answer, signingBoundaryTrace parameter (.inr input) answer)) <$> liftM (OracleWorld.query (.inr input)) := by
+  simp only [boundaryComputation, simulateQ_spec_query, QueryImpl.withTrace_apply, QueryImpl.id'_apply,
+    WriterT.run_bind, WriterT.run_map, WriterT.run_tell, WriterT.run_monadLift, map_pure, one_mul, bind_pure_comp,
+    Functor.map_map]
+
+theorem fixedTrace_boundary_hash {Result : Type} (parameter : PublicParameter) (f : QueryImpl HashSpec Id) (computation : OracleComp HashSpec Result) :
+    fixedTrace f (boundaryComputation parameter (liftM computation)) = pure (boundaryEval parameter f computation, answerTrace f computation) := by
+  induction computation using OracleComp.inductionOn with
+  | pure value =>
+      simp only [liftM_pure, boundaryComputation, simulateQ_pure, WriterT.run_pure, fixedTrace_pure,
+        boundaryEval_pure, answerTrace, queriedInputs_pure, List.map_nil]
+      rfl
+  | query_bind input next ih =>
+      rw [liftM_bind, boundaryComputation_bind, fixedTrace_bind]
+      change (fixedTrace f (boundaryComputation parameter (liftM (OracleWorld.query (.inr input)))) >>= _) = _
+      rw [boundaryComputation_hash_query, fixedTrace_map, fixedTrace_hash_query, map_pure, pure_bind,
+        fixedTrace_map, ih, map_pure, map_pure]
+      simp only [answerTrace, queriedInputs_query_bind, List.map_cons, FreeMonoid.ofList_cons]
+      rw [boundaryEval_bind, boundaryEval_hash_query]
+      rfl
+
+end SphincsSecurity.Concrete.OtsContactTrace
diff --git a/formal/sphincs/SphincsSecurity/Proof/Reference/VerifierWitnessClassification.lean b/formal/sphincs/SphincsSecurity/Proof/Reference/VerifierWitnessClassification.lean
new file mode 100644
index 000000000..0afe59c59
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Reference/VerifierWitnessClassification.lean
@@ -0,0 +1,42 @@
+import SphincsSecurity.Proof.Hypertree.ReferenceHypertreeWitness
+import SphincsSecurity.Proof.Fts.FtsVerifierWitness
+namespace SphincsSecurity.Concrete.OtsVerifierWitness
+
+open _root_.OracleComp OracleSpec OtsContactTrace
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] chainWalk sequenceFin canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+
+theorem ReferenceLayerOpening.honest {f : QueryImpl HashSpec Id} {key : SecretKey} {words : OtsReferenceWords} {selections : ReferenceFamily}
+    {index : Index} {signature : Signature} {lay : Layer} (h : ReferenceLayerOpening f key words selections index signature lay) :
+    HonestLayerOpening f key.parameter key.otsSecret lay (treeIndexAt index lay) (leafIndexAt index lay)
+      (evalWithAnswerFn f (layerMessage key index lay)) (signature.counter lay) (signature.chainValue lay) (signaturePath signature lay) := by
+  obtain ⟨_, _, _, he, hv, hp⟩ := h
+  exact ⟨words lay (treeIndexAt index lay) (leafIndexAt index lay), he, hv, hp⟩
+
+theorem verify_classification (f : QueryImpl HashSpec Id) (key : SecretKey) (words : OtsReferenceWords)
+    (messages : EncodingPosition → Digest) (selections : ReferenceFamily) (message : Message) (signature : Signature) (trace : Trace)
+    (hvalid : ∀ lay tree leaf, TargetSum.Valid (words lay tree leaf))
+    (hmessages : ∀ index lay, messages ⟨lay, treeIndexAt index lay, leafIndexAt index lay⟩ = evalWithAnswerFn f (layerMessage key index lay))
+    (hroot : key.root = honestNode f key.parameter topLayer rootTree (key.otsSecret topLayer rootTree) (layerHeight topLayer) 0)
+    (hverify : evalWithAnswerFn f (verify ⟨key.root, key.parameter⟩ message signature) = true)
+    (hrun : ContainsRun f trace (verify ⟨key.root, key.parameter⟩ message signature)) :
+    ∃ digest, evalWithAnswerFn f (messageDigest key.parameter key.root message signature.randomness) = digest ∧
+      ContainsRun f trace (messageDigest key.parameter key.root message signature.randomness) ∧ Admissible digest ∧
+      ((FullyHonestOpening f (recordedCache f trace) key (digestIndex digest) (digestLeaves digest) signature ∧
+        (∀ lay, ReferenceLayerOpening f key words selections (digestIndex digest) signature lay) ∧
+        ∀ tree, FtsVerifierWitness.TrueSecretQuery f key (digestIndex digest) tree (digestLeaves digest (ftsIndexOf tree)) trace) ∨
+        LayerException f key words messages selections trace ∨ FtsVerifierWitness.Exception f key (digestIndex digest) trace) := by
+  obtain ⟨digest, hd, hdrun, ha, hlayers, hftsrun, hlayersrun⟩ := verify_extract ⟨key.root, key.parameter⟩ message signature hverify hrun.cached
+  refine ⟨digest, hd, (recordedCache_run_iff f trace _).mp hdrun, ha, ?_⟩
+  rcases hypertree_classification f key words messages selections (digestIndex digest) (digestLeaves digest) signature trace
+      (fun lay => hvalid lay _ _) (hmessages (digestIndex digest)) hroot hlayers ((recordedCache_run_iff f trace _).mp hlayersrun)
+      with ⟨hfts, hopenings⟩ | he
+  · rcases FtsVerifierWitness.recover_classification f key (digestIndex digest) (digestLeaves digest) signature.ftsSecret signature.ftsPath trace hfts
+        ((recordedCache_run_iff f trace _).mp hftsrun) with ⟨hftsOpening, hqueries⟩ | he
+    · refine Or.inl ⟨?_, fun lay => (hopenings lay).1, hqueries⟩
+      exact ⟨fun lay => ⟨(hopenings lay).1.honest, (hopenings lay).2.1⟩, hftsOpening, hftsrun, fun lay => (hopenings lay).2.2⟩
+    · exact Or.inr (Or.inr he)
+  · exact Or.inr (Or.inl he)
+
+end SphincsSecurity.Concrete.OtsVerifierWitness
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/AdaptiveResidualErasure.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/AdaptiveResidualErasure.lean
new file mode 100644
index 000000000..eef685ad2
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/AdaptiveResidualErasure.lean
@@ -0,0 +1,148 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.AdaptiveResidualLabels
+namespace SphincsSecurity.Concrete.AdaptiveResidualLabels
+
+open _root_.OracleComp OracleSpec HiddenLabelObservation UniformTableCompletion RetainedObservation ResidualTableCompletion
+set_option backward.isDefEq.respectTransparency false
+
+variable {Coordinate Cell Memory AuxIndex : Type} {auxSpec : OracleSpec AuxIndex}
+  [Fintype Coordinate] [DecidableEq Coordinate] [Fintype Cell] [DecidableEq Cell]
+
+omit [Fintype Cell] in
+theorem lazyRun_nonempty {Result : Type} (environment : Environment auxSpec Coordinate Cell Memory)
+    (computation : OracleComp (World auxSpec Coordinate Cell) Result) (state : State Coordinate Cell Memory)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (result : Option Result × State Coordinate Cell Memory) (h : lazyRun environment computation state result ≠ 0) :
+    ∀ coordinate, (result.2.candidates coordinate).Nonempty := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      simp only [lazyRun, runWith_pure, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at h
+      subst result
+      exact ha
+  | query_bind input next ih =>
+      cases input with
+      | inl input =>
+          simp only [lazyRun, runWith_query_bind, lazyImpl, OptionT.run_mk, StateT.run_mk,
+            bind_assoc, pure_bind] at h
+          obtain ⟨⟨answer, memory⟩, _, hnext⟩ := (bind_nonzero _ _ _).mp h
+          cases answer with
+          | none =>
+              simp only [Option.elim_none, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hnext
+              subst result
+              exact ha
+          | some answer => exact ih answer { state with memory := memory } ha result hnext
+      | inr input =>
+          cases input with
+          | read input =>
+              simp only [lazyRun, runWith_query_bind, lazyImpl, OptionT.run_mk, StateT.run_mk,
+                bind_assoc, pure_bind, Option.elim_some] at h
+              obtain ⟨answer, _, hnext⟩ := (bind_nonzero _ _ _).mp h
+              exact ih answer (readState environment state input answer) ha result hnext
+          | probe input test =>
+              cases hcache : state.rows input with
+              | some answer =>
+                  simp only [lazyRun, runWith_query_bind, lazyImpl, OptionT.run_mk, StateT.run_mk,
+                    hcache, pure_bind, Option.elim_some] at h
+                  exact ih answer (readState environment state input answer) ha result h
+              | none =>
+                  simp only [lazyRun, runWith_query_bind, lazyImpl, OptionT.run_mk, StateT.run_mk,
+                    hcache, observe_bind, pure_bind, Option.elim_none, Option.elim_some] at h
+                  rcases (observe_nonzero _ _ _ _).mp h with ⟨_, hstop⟩ | ⟨answer, hanswer, hnext⟩
+                  · simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hstop
+                    subst result
+                    exact ha
+                  · exact ih answer (probeState environment state input test answer)
+                      (lazyResponse_nonempty state.candidates test answer hanswer) result hnext
+          | disclose coordinate =>
+              simp only [lazyRun, runWith_query_bind, lazyImpl, OptionT.run_mk, StateT.run_mk,
+                bind_assoc, pure_bind, Option.elim_some] at h
+              obtain ⟨value, _, hnext⟩ := (bind_nonzero _ _ _).mp h
+              exact ih value (disclosedState environment state coordinate value)
+                (discloseTableValue_nonempty state.candidates ha coordinate value) result hnext
+
+def erase {Result : Type}
+    (result : Option ((Coordinate → Digest) × (Cell → HashOutput) × Result) × State Coordinate Cell Memory) :
+    Option Result × State Coordinate Cell Memory := (result.1.map (fun data => data.2.2), result.2)
+
+omit [Fintype Coordinate] [DecidableEq Coordinate] [Fintype Cell] [DecidableEq Cell] in
+theorem erase_retain {Result : Type} (labels : Coordinate → Digest) (table : Cell → HashOutput)
+    (result : Option Result × State Coordinate Cell Memory) : erase (retain labels table result) = result := by
+  rcases result with ⟨value, state⟩
+  cases value <;> rfl
+
+theorem erase_finish {Result : Type} (result : Option Result × State Coordinate Cell Memory)
+    (ha : ∀ coordinate, (result.2.candidates coordinate).Nonempty) : erase <$> finish result = pure result := by
+  rcases result with ⟨value, state⟩
+  cases value with
+  | none => simp only [finish, map_pure, erase, Option.map_none]
+  | some value =>
+      simp only [finish, map_bind, map_pure, erase, Option.map_some, completeRows_bind_const]
+      rw [complete_of_nonempty state.candidates ha, lift_bind_const]
+
+theorem run_erasure {Result : Type} (environment : Environment auxSpec Coordinate Cell Memory)
+    (computation : OracleComp (World auxSpec Coordinate Cell) Result) (state : State Coordinate Cell Memory)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty) :
+    (complete state.candidates >>= fun labels => completeRows state.rows >>= fun table =>
+      observedRun environment labels table computation state) = lazyRun environment computation state := by
+  have h := congrArg (fun law => erase <$> law) (run_posterior environment computation state ha)
+  simp only [map_bind, ← comp_map, Function.comp_def, erase_retain, id_map'] at h
+  calc
+    _ = lazyRun environment computation state >>= fun result => erase <$> finish result := h
+    _ = lazyRun environment computation state >>= pure := by
+      apply RetainedObservation.bind_congr
+      intro result hresult
+      exact erase_finish result (lazyRun_nonempty environment computation state ha result hresult)
+    _ = _ := bind_pure _
+
+omit [Fintype Coordinate] [Fintype Cell] in
+theorem observedRun_bind_const {Result Other : Type} (environment : Environment auxSpec Coordinate Cell Memory)
+    (labels : Coordinate → Digest) (table : Cell → HashOutput)
+    (computation : OracleComp (World auxSpec Coordinate Cell) Result) (state : State Coordinate Cell Memory)
+    (after : SPMF Other) : (observedRun environment labels table computation state >>= fun _ => after) = after := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure result => simp only [observedRun, runWith_pure, pure_bind]
+  | query_bind input next ih =>
+      cases input with
+      | inl input =>
+          simp only [observedRun, runWith_query_bind, observedImpl, OptionT.run_mk, StateT.run_mk,
+            bind_assoc, pure_bind]
+          dsimp only [OracleSpec.Range, World, OracleSpec.add_apply_inl]
+          have hnext (result : Option (auxSpec.Range input) × Memory) :
+              (result.1.elim (pure (none, { state with memory := result.2 }))
+                (fun answer => runWith (observedImpl environment labels table) (next answer)
+                  { state with memory := result.2 }) >>= fun _ => after) = after := by
+            rcases result with ⟨answer, memory⟩
+            cases answer with
+            | none => exact pure_bind _ _
+            | some answer => exact ih answer { state with memory := memory }
+          simp_rw [hnext]
+          exact lift_bind_const _ _
+      | inr input =>
+          cases input with
+          | read input =>
+              simp only [observedRun, runWith_query_bind, observedImpl, OptionT.run_mk, StateT.run_mk, pure_bind, Option.elim_some]
+              exact ih (table input) (readState environment state input (table input))
+          | probe input test =>
+              cases hcache : state.rows input with
+              | some answer =>
+                  simp only [observedRun, runWith_query_bind, observedImpl, OptionT.run_mk, StateT.run_mk, hcache, pure_bind, Option.elim_some]
+                  exact ih answer (readState environment state input answer)
+              | none =>
+                  simp only [observedRun, runWith_query_bind, observedImpl, OptionT.run_mk, StateT.run_mk, hcache]
+                  split
+                  · simp only [pure_bind, Option.elim_some]
+                    exact ih (table input) (probeState environment state input test (table input))
+                  · simp only [pure_bind, Option.elim_none]
+          | disclose coordinate =>
+              simp only [observedRun, runWith_query_bind, observedImpl, OptionT.run_mk, StateT.run_mk, pure_bind, Option.elim_some]
+              exact ih (labels coordinate) (disclosedState environment state coordinate (labels coordinate))
+
+theorem lazyRun_bind_const {Result Other : Type} (environment : Environment auxSpec Coordinate Cell Memory)
+    (computation : OracleComp (World auxSpec Coordinate Cell) Result) (state : State Coordinate Cell Memory)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty) (after : SPMF Other) :
+    (lazyRun environment computation state >>= fun _ => after) = after := by
+  rw [← run_erasure environment computation state ha]
+  simp only [bind_assoc, observedRun_bind_const, completeRows_bind_const]
+  rw [complete_of_nonempty state.candidates ha, lift_bind_const]
+
+end SphincsSecurity.Concrete.AdaptiveResidualLabels
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/AdaptiveResidualLabels.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/AdaptiveResidualLabels.lean
new file mode 100644
index 000000000..7c937b86a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/AdaptiveResidualLabels.lean
@@ -0,0 +1,216 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.ResidualProbeCompletion
+namespace SphincsSecurity.Concrete.AdaptiveResidualLabels
+
+open _root_.OracleComp OracleSpec HiddenLabelObservation UniformTableCompletion RetainedObservation ResidualTableCompletion
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+inductive Request (Coordinate Cell : Type) where
+  | read (cell : Cell)
+  | probe (cell : Cell) (test : Probe Coordinate)
+  | disclose (coordinate : Coordinate)
+
+abbrev ResidualSpec (Coordinate Cell : Type) : OracleSpec (Request Coordinate Cell)
+  | .read _ => HashOutput
+  | .probe _ _ => HashOutput
+  | .disclose _ => Digest
+
+abbrev World {AuxIndex : Type} (auxSpec : OracleSpec AuxIndex) (Coordinate Cell : Type) :=
+  auxSpec + ResidualSpec Coordinate Cell
+
+structure State (Coordinate Cell Memory : Type) where
+  candidates : Coordinate → Finset Digest
+  rows : Cache Cell
+  memory : Memory
+
+structure Environment {AuxIndex : Type} (auxSpec : OracleSpec AuxIndex) (Coordinate Cell Memory : Type) where
+  auxiliary : State Coordinate Cell Memory → (input : auxSpec.Domain) → PMF (Option (auxSpec.Range input) × Memory)
+  rowAnswer : Memory → Cell → HashOutput → Memory
+  probeAnswer : Memory → Cell → Probe Coordinate → HashOutput → Memory
+  probeStop : Memory → Cell → Probe Coordinate → Memory
+  disclosure : Memory → Coordinate → Digest → Memory
+
+variable {Coordinate Cell Memory AuxIndex : Type} {auxSpec : OracleSpec AuxIndex}
+  [Fintype Coordinate] [DecidableEq Coordinate] [Fintype Cell] [DecidableEq Cell]
+
+def readState (environment : Environment auxSpec Coordinate Cell Memory) (state : State Coordinate Cell Memory)
+    (input : Cell) (answer : HashOutput) : State Coordinate Cell Memory :=
+  ⟨state.candidates, Function.update state.rows input (some answer), environment.rowAnswer state.memory input answer⟩
+
+def probeState (environment : Environment auxSpec Coordinate Cell Memory) (state : State Coordinate Cell Memory)
+    (input : Cell) (test : Probe Coordinate) (answer : HashOutput) : State Coordinate Cell Memory :=
+  ⟨test.restrict state.candidates answer, Function.update state.rows input (some answer),
+    environment.probeAnswer state.memory input test answer⟩
+
+def stoppedState (environment : Environment auxSpec Coordinate Cell Memory) (state : State Coordinate Cell Memory)
+    (input : Cell) (test : Probe Coordinate) : State Coordinate Cell Memory :=
+  { state with memory := environment.probeStop state.memory input test }
+
+def disclosedState (environment : Environment auxSpec Coordinate Cell Memory) (state : State Coordinate Cell Memory)
+    (coordinate : Coordinate) (value : Digest) : State Coordinate Cell Memory :=
+  ⟨discloseTableValue state.candidates coordinate value, state.rows,
+    environment.disclosure state.memory coordinate value⟩
+
+noncomputable def observedImpl (environment : Environment auxSpec Coordinate Cell Memory)
+    (labels : Coordinate → Digest) (table : Cell → HashOutput) :
+    QueryImpl (World auxSpec Coordinate Cell) (OptionT (StateT (State Coordinate Cell Memory) SPMF))
+  | .inl input => OptionT.mk <| StateT.mk fun state =>
+      (liftM (environment.auxiliary state input) : SPMF _) >>= fun result =>
+        pure (result.1, { state with memory := result.2 })
+  | .inr (.read input) => OptionT.mk <| StateT.mk fun state =>
+      pure (some (table input), readState environment state input (table input))
+  | .inr (.probe input test) => OptionT.mk <| StateT.mk fun state =>
+      match state.rows input with
+      | some answer => pure (some answer, readState environment state input answer)
+      | none => if test.keep labels (table input) then
+          pure (some (table input), probeState environment state input test (table input))
+        else pure (none, stoppedState environment state input test)
+  | .inr (.disclose coordinate) => OptionT.mk <| StateT.mk fun state =>
+      pure (some (labels coordinate), disclosedState environment state coordinate (labels coordinate))
+
+noncomputable def lazyImpl (environment : Environment auxSpec Coordinate Cell Memory) :
+    QueryImpl (World auxSpec Coordinate Cell) (OptionT (StateT (State Coordinate Cell Memory) SPMF))
+  | .inl input => OptionT.mk <| StateT.mk fun state =>
+      (liftM (environment.auxiliary state input) : SPMF _) >>= fun result =>
+        pure (result.1, { state with memory := result.2 })
+  | .inr (.read input) => OptionT.mk <| StateT.mk fun state =>
+      reply state.rows input >>= fun answer => pure (some answer, readState environment state input answer)
+  | .inr (.probe input test) => OptionT.mk <| StateT.mk fun state =>
+      match state.rows input with
+      | some answer => pure (some answer, readState environment state input answer)
+      | none => observe (lazyResponse state.candidates test)
+          (pure (none, stoppedState environment state input test))
+          (fun answer => pure (some answer, probeState environment state input test answer))
+  | .inr (.disclose coordinate) => OptionT.mk <| StateT.mk fun state =>
+      cell (state.candidates coordinate) >>= fun value =>
+        pure (some value, disclosedState environment state coordinate value)
+
+noncomputable def runWith {Result : Type}
+    (implementation : QueryImpl (World auxSpec Coordinate Cell) (OptionT (StateT (State Coordinate Cell Memory) SPMF)))
+    (computation : OracleComp (World auxSpec Coordinate Cell) Result) (state : State Coordinate Cell Memory) :
+    SPMF (Option Result × State Coordinate Cell Memory) :=
+  (OptionT.run (simulateQ implementation computation)).run state
+
+noncomputable def observedRun {Result : Type} (environment : Environment auxSpec Coordinate Cell Memory)
+    (labels : Coordinate → Digest) (table : Cell → HashOutput)
+    (computation : OracleComp (World auxSpec Coordinate Cell) Result) (state : State Coordinate Cell Memory) :=
+  runWith (observedImpl environment labels table) computation state
+
+noncomputable def lazyRun {Result : Type} (environment : Environment auxSpec Coordinate Cell Memory)
+    (computation : OracleComp (World auxSpec Coordinate Cell) Result) (state : State Coordinate Cell Memory) :=
+  runWith (lazyImpl environment) computation state
+
+omit [Fintype Coordinate] [DecidableEq Coordinate] [Fintype Cell] [DecidableEq Cell] in
+theorem runWith_pure {Result : Type}
+    (implementation : QueryImpl (World auxSpec Coordinate Cell) (OptionT (StateT (State Coordinate Cell Memory) SPMF)))
+    (value : Result) (state : State Coordinate Cell Memory) : runWith implementation (pure value) state = pure (some value, state) := by
+  simp only [runWith, simulateQ_pure, OptionT.run_pure, StateT.run_pure]
+
+omit [Fintype Coordinate] [DecidableEq Coordinate] [Fintype Cell] [DecidableEq Cell] in
+theorem runWith_query_bind {Result : Type}
+    (implementation : QueryImpl (World auxSpec Coordinate Cell) (OptionT (StateT (State Coordinate Cell Memory) SPMF)))
+    (input : (World auxSpec Coordinate Cell).Domain)
+    (next : (World auxSpec Coordinate Cell).Range input → OracleComp (World auxSpec Coordinate Cell) Result)
+    (state : State Coordinate Cell Memory) :
+    runWith implementation (liftM ((World auxSpec Coordinate Cell).query input) >>= next) state =
+      ((implementation input).run.run state >>= fun result =>
+        result.1.elim (pure (none, result.2)) (fun answer => runWith implementation (next answer) result.2)) := by
+  simp only [runWith, simulateQ_bind, simulateQ_spec_query, OptionT.run_bind, Option.elimM, StateT.run_bind]
+  apply congrArg (fun continuation => (implementation input).run.run state >>= continuation)
+  funext result
+  rcases result with ⟨answer, state⟩
+  cases answer <;> rfl
+
+def retain {Result : Type} (labels : Coordinate → Digest) (table : Cell → HashOutput)
+    (result : Option Result × State Coordinate Cell Memory) :
+    Option ((Coordinate → Digest) × (Cell → HashOutput) × Result) × State Coordinate Cell Memory :=
+  (result.1.map (fun value => (labels, table, value)), result.2)
+
+noncomputable def finish {Result : Type} (result : Option Result × State Coordinate Cell Memory) :
+    SPMF (Option ((Coordinate → Digest) × (Cell → HashOutput) × Result) × State Coordinate Cell Memory) :=
+  match result.1 with
+  | none => pure (none, result.2)
+  | some value => complete result.2.candidates >>= fun labels =>
+      completeRows result.2.rows >>= fun table => pure (some (labels, table, value), result.2)
+
+private theorem bind_if {A B : Type} (p : Prop) [Decidable p] (left right : SPMF A) (next : A → SPMF B) :
+    ((if p then left else right) >>= next) = if p then left >>= next else right >>= next := by
+  split <;> rfl
+
+private theorem map_if {A B : Type} (p : Prop) [Decidable p] (left right : SPMF A) (f : A → B) :
+    f <$> (if p then left else right) = if p then f <$> left else f <$> right := by
+  split <;> rfl
+
+theorem run_posterior {Result : Type} (environment : Environment auxSpec Coordinate Cell Memory)
+    (computation : OracleComp (World auxSpec Coordinate Cell) Result) (state : State Coordinate Cell Memory)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty) :
+    (complete state.candidates >>= fun labels => completeRows state.rows >>= fun table =>
+      retain labels table <$> observedRun environment labels table computation state) =
+        (lazyRun environment computation state >>= finish) := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure result =>
+      simp only [observedRun, lazyRun, runWith_pure, map_pure, pure_bind, retain, Option.map_some, finish]
+  | query_bind input next ih =>
+      cases input with
+      | inl input =>
+          simp only [observedRun, lazyRun, runWith_query_bind, observedImpl, lazyImpl, OptionT.run_mk,
+            StateT.run_mk, bind_assoc, pure_bind, map_bind]
+          conv_lhs => enter [2, labels]; rw [RetainedObservation.bind_comm]
+          rw [RetainedObservation.bind_comm]
+          apply congrArg ((liftM (environment.auxiliary state input) : SPMF _) >>= ·)
+          funext result
+          rcases result with ⟨answer, memory⟩
+          cases answer with
+          | none =>
+              simp only [map_pure, retain, Option.map_none, pure_bind, Option.elim_none, finish, completeRows_bind_const]
+              rw [complete_of_nonempty _ ha, lift_bind_const]
+          | some answer => exact ih answer { state with memory := memory } ha
+      | inr input =>
+          cases input with
+          | read input =>
+              simp only [observedRun, lazyRun, runWith_query_bind, observedImpl, lazyImpl, OptionT.run_mk,
+                StateT.run_mk, bind_assoc, pure_bind, Option.elim_some]
+              have hread (labels : Coordinate → Digest) := bind_read state.rows input
+                (fun answer table => retain labels table <$>
+                  runWith (observedImpl environment labels table) (next answer) (readState environment state input answer))
+              simp_rw [hread]
+              rw [RetainedObservation.bind_comm]
+              apply congrArg (reply state.rows input >>= ·)
+              funext answer
+              exact ih answer (readState environment state input answer) ha
+          | probe input test =>
+              cases hcache : state.rows input with
+              | some answer =>
+                  simp only [observedRun, lazyRun, runWith_query_bind, observedImpl, lazyImpl, OptionT.run_mk,
+                    StateT.run_mk, hcache, pure_bind, Option.elim_some]
+                  have hrows : Function.update state.rows input (some answer) = state.rows := by
+                    rw [← hcache, Function.update_eq_self]
+                  simpa only [readState, hrows, observedRun, lazyRun] using ih answer (readState environment state input answer) ha
+              | none =>
+                  change HashOutput → OracleComp (World auxSpec Coordinate Cell) Result at next
+                  dsimp only [OracleSpec.Range, World, ResidualSpec] at ih ⊢
+                  simp only [observedRun, lazyRun, runWith_query_bind, observedImpl, lazyImpl, OptionT.run_mk,
+                    StateT.run_mk, hcache, observe_bind, pure_bind, Option.elim_none, Option.elim_some, finish]
+                  dsimp only [OracleSpec.Range, World, OracleSpec.add_apply_inr, ResidualSpec]
+                  simp only [bind_if, pure_bind, Option.elim_none, Option.elim_some, map_if, map_pure, retain, Option.map_none]
+                  rw [ResidualProbeCompletion.bind_fresh_probe state.candidates ha state.rows input hcache test
+                    (pure (none, stoppedState environment state input test))
+                    (fun answer labels table => retain labels table <$>
+                      runWith (observedImpl environment labels table) (next answer) (probeState environment state input test answer))]
+                  apply observe_congr
+                  intro answer hanswer
+                  exact ih answer (probeState environment state input test answer)
+                    (lazyResponse_nonempty state.candidates test answer hanswer)
+          | disclose coordinate =>
+              simp only [observedRun, lazyRun, runWith_query_bind, observedImpl, lazyImpl, OptionT.run_mk,
+                StateT.run_mk, bind_assoc, pure_bind, Option.elim_some]
+              rw [bind_disclose state.candidates coordinate (fun value labels => completeRows state.rows >>= fun table =>
+                retain labels table <$> runWith (observedImpl environment labels table) (next value)
+                  (disclosedState environment state coordinate value))]
+              apply congrArg (cell (state.candidates coordinate) >>= ·)
+              funext value
+              exact ih value (disclosedState environment state coordinate value)
+                (discloseTableValue_nonempty state.candidates ha coordinate value)
+
+end SphincsSecurity.Concrete.AdaptiveResidualLabels
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/CanonicalResidualQuery.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/CanonicalResidualQuery.lean
new file mode 100644
index 000000000..307b1c671
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/CanonicalResidualQuery.lean
@@ -0,0 +1,97 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.CanonicalGraphResidual
+import SphincsSecurity.Proof.Hypertree.CanonicalProbeRouting
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec OracleComp.DeferredSampling CanonicalProbeRouting
+set_option backward.isDefEq.respectTransparency false
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalGraphInputs canonicalPayloadInputs canonicalGraphOrder instFintypePosition
+
+variable (parameter : PublicParameter)
+  (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+  (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+
+noncomputable local instance residualQueryTableSampleable (inputs : Finset HashInput) : SampleableType (inputs → HashOutput) :=
+  SampleableType.ofFintype (inputs → HashOutput)
+
+noncomputable def programmedHash (labels : CanonicalGraphLabels) (residual : QueryImpl HashSpec Id) : QueryImpl HashSpec Id :=
+  fun input => (decodePosition parameter input).elim (residual input) fun position =>
+    if input = canonicalGraphInput parameter otsSecret ftsSecret position labels then labels position else residual input
+
+theorem canonicalGraphInput_at (position : Position) (labels : CanonicalGraphLabels) :
+    AtPosition parameter (canonicalGraphInput parameter otsSecret ftsSecret position labels) position := ⟨_, rfl⟩
+
+theorem programmedHash_at (labels : CanonicalGraphLabels) (residual : QueryImpl HashSpec Id) (position : Position) :
+    programmedHash parameter otsSecret ftsSecret labels residual
+      (canonicalGraphInput parameter otsSecret ftsSecret position labels) = labels position := by
+  simp only [programmedHash, (decodePosition_some_iff _ _ _).mpr
+    (canonicalGraphInput_at parameter otsSecret ftsSecret position labels), Option.elim_some, if_true]
+
+theorem programmedHash_other (labels : CanonicalGraphLabels) (residual : QueryImpl HashSpec Id) (input : HashInput)
+    (hne : ∀ position, input ≠ canonicalGraphInput parameter otsSecret ftsSecret position labels) :
+    programmedHash parameter otsSecret ftsSecret labels residual input = residual input := by
+  rw [programmedHash]
+  cases hdecode : decodePosition parameter input with
+  | none => rfl
+  | some position => simp only [Option.elim_some, if_neg (hne position)]
+
+theorem canonicalGraphLabels_programmedHash (labels : CanonicalGraphLabels) (residual : QueryImpl HashSpec Id) :
+    canonicalGraphLabels parameter otsSecret ftsSecret (programmedHash parameter otsSecret ftsSecret labels residual) = labels := by
+  funext position
+  induction hdepth : position.depth using Nat.strong_induction_on generalizing position with
+  | h depth ih =>
+      rw [canonicalGraphLabels_consistent]
+      calc
+        _ = programmedHash parameter otsSecret ftsSecret labels residual
+            (canonicalGraphInput parameter otsSecret ftsSecret position labels) := by
+          apply congrArg (programmedHash parameter otsSecret ftsSecret labels residual)
+          apply canonicalGraphInput_congr
+          intro child hchild
+          apply congrArg truncateHash
+          have hlt : child.depth < depth := by
+            rw [← hdepth]
+            exact Position.depth_lt_of_mem_children hchild
+          exact ih child.depth hlt child rfl
+        _ = labels position := programmedHash_at parameter otsSecret ftsSecret labels residual position
+
+theorem noncanonical_at (labels : CanonicalGraphLabels) (input : HashInput) (position : Position)
+    (hat : AtPosition parameter input position)
+    (hne : input ≠ canonicalGraphInput parameter otsSecret ftsSecret position labels) :
+    ∀ other, input ≠ canonicalGraphInput parameter otsSecret ftsSecret other labels := by
+  intro other heq
+  have hother : AtPosition parameter input other := ⟨_, heq⟩
+  have hposition := atPosition_unique parameter hat hother
+  subst other
+  exact hne heq
+
+variable (inputs : Finset HashInput) (hinputs : canonicalGraphInputs parameter ⊆ inputs)
+
+theorem finiteHashAnswer_program_at (labels : CanonicalGraphLabels) (residual : inputs → HashOutput) (position : Position) :
+    finiteHashAnswer ∅ inputs (programCanonicalGraph parameter otsSecret ftsSecret inputs hinputs labels residual)
+      (canonicalGraphInput parameter otsSecret ftsSecret position labels) = labels position := by
+  rw [finiteHashAnswer_none _ _ _ _ (hinputs (canonicalGraphInput_mem parameter otsSecret ftsSecret position labels)) (by simp)]
+  exact programCanonicalGraph_at parameter otsSecret ftsSecret inputs hinputs labels residual position
+
+theorem finiteHashAnswer_program_other (labels : CanonicalGraphLabels) (residual : inputs → HashOutput) (input : HashInput)
+    (hne : ∀ position, input ≠ canonicalGraphInput parameter otsSecret ftsSecret position labels) :
+    finiteHashAnswer ∅ inputs (programCanonicalGraph parameter otsSecret ftsSecret inputs hinputs labels residual) input =
+      finiteHashAnswer ∅ inputs residual input := by
+  by_cases hin : input ∈ inputs
+  · rw [finiteHashAnswer_none _ _ _ _ hin (by simp), finiteHashAnswer_none _ _ _ _ hin (by simp)]
+    exact programCanonicalGraph_other parameter otsSecret ftsSecret inputs hinputs labels residual ⟨input, hin⟩ hne
+  · simp only [finiteHashAnswer, QueryCache.empty_apply, Option.getD_none, dif_neg hin]
+
+theorem finiteHashAnswer_program_eq (labels : CanonicalGraphLabels) (residual : inputs → HashOutput) :
+    finiteHashAnswer ∅ inputs (programCanonicalGraph parameter otsSecret ftsSecret inputs hinputs labels residual) =
+      programmedHash parameter otsSecret ftsSecret labels (finiteHashAnswer ∅ inputs residual) := by
+  funext input
+  by_cases hcanonical : ∃ position, input = canonicalGraphInput parameter otsSecret ftsSecret position labels
+  · obtain ⟨position, rfl⟩ := hcanonical
+    rw [finiteHashAnswer_program_at, programmedHash_at]
+  · have hne : ∀ position, input ≠ canonicalGraphInput parameter otsSecret ftsSecret position labels :=
+      fun position heq => hcanonical ⟨position, heq⟩
+    rw [finiteHashAnswer_program_other parameter otsSecret ftsSecret inputs hinputs labels residual input hne,
+      programmedHash_other parameter otsSecret ftsSecret labels _ input hne]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/CanonicalResidualRouting.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/CanonicalResidualRouting.lean
new file mode 100644
index 000000000..60f4d0e84
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/CanonicalResidualRouting.lean
@@ -0,0 +1,101 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.CanonicalResidualQuery
+namespace SphincsSecurity.Concrete.CanonicalProbeRouting
+
+open _root_.OracleComp HiddenLabelObservation
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def tableReply (parameter : PublicParameter) (actual : Labels)
+    (replies : CanonicalGraphLabels) (outside : QueryImpl HashSpec Id) (input : HashInput) : HashOutput :=
+  (decodePosition parameter input).elim (outside input)
+    (fun position => if input = inputOf parameter actual position then replies position else outside input)
+
+theorem tableReply_programmed (parameter : PublicParameter)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (replies : CanonicalGraphLabels)
+    (outside : QueryImpl HashSpec Id) (input : HashInput) :
+    tableReply parameter (CanonicalCoordinate.value otsSecret ftsSecret replies) replies outside input =
+      programmedHash parameter otsSecret ftsSecret replies outside input := by
+  simp only [tableReply, programmedHash, inputOf_canonical]
+
+noncomputable def stoppedTableReply (parameter : PublicParameter) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (actual : Labels)
+    (replies : CanonicalGraphLabels) (outside : QueryImpl HashSpec Id) (input : HashInput) : Option HashOutput :=
+  let answer := tableReply parameter actual replies outside input
+  if Bad parameter words disclosed actual input answer then none else some answer
+
+noncomputable def routedTableReply (publicReplies : CanonicalGraphLabels) (actual : Labels)
+    (outside : QueryImpl HashSpec Id) (input : HashInput) : Route → Option HashOutput
+  | .outside => some (outside input)
+  | .canonical position => some (publicReplies position)
+  | .probe test => if test.keep actual (outside input) then some (outside input) else none
+
+theorem stoppedTableReply_eq_routed (parameter : PublicParameter) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (actual : Labels)
+    (replies publicReplies : CanonicalGraphLabels)
+    (hreplies : ∀ position, ¬CanonicalCoordinate.Hidden words disclosed (.graph position) →
+      publicReplies position = replies position)
+    (outside : QueryImpl HashSpec Id) (input : HashInput) (routing : Route)
+    (hspec : RouteSpec parameter words disclosed actual input routing) :
+    stoppedTableReply parameter words disclosed actual replies outside input =
+      routedTableReply publicReplies actual outside input routing := by
+  have hsafe := safe_iff_not_bad parameter words disclosed actual input routing hspec
+  cases routing with
+  | outside =>
+      have hdecode := (decodePosition_none_iff parameter input).mpr hspec
+      have hbad : ¬Bad parameter words disclosed actual input (outside input) :=
+        (hsafe (outside input)).mp trivial
+      simp only [stoppedTableReply, tableReply, hdecode, Option.elim_none, if_neg hbad, routedTableReply]
+  | canonical position =>
+      obtain ⟨hat, hinput, hpublic⟩ := hspec
+      have hdecode := (decodePosition_some_iff parameter input position).mpr hat
+      have hbad : ¬Bad parameter words disclosed actual input (replies position) :=
+        (hsafe (replies position)).mp trivial
+      have hreply := hreplies position (parent_public_of_no_hidden_child words disclosed position hpublic)
+      simp only [stoppedTableReply, tableReply, hdecode, Option.elim_some, if_pos hinput,
+        if_neg hbad, routedTableReply, hreply]
+  | probe test =>
+      cases test with
+      | pair child parent hne candidate =>
+          obtain ⟨position, hat, rfl, hslot, hhidden, hinput⟩ := hspec
+          have hdecode := (decodePosition_some_iff parameter input position).mpr hat
+          have heq : input = inputOf parameter actual position ↔ candidate = actual child := by
+            rw [hinput, unary_eq_inputOf_iff parameter actual position child hslot candidate]
+          by_cases hcanonical : input = inputOf parameter actual position
+          · have hbad : Bad parameter words disclosed actual input (replies position) := by
+              refine ⟨position, hat, Or.inl ⟨?_, hcanonical⟩⟩
+              exact ⟨child, by rw [hslot]; exact List.mem_singleton_self _, hhidden⟩
+            simp only [stoppedTableReply, tableReply, hdecode, Option.elim_some, if_pos hcanonical,
+              if_pos hbad, routedTableReply, Probe.keep, heq.mp hcanonical, ne_eq, not_true_eq_false, false_and, if_false]
+          · have hkeep := hsafe (outside input)
+            change Probe.keep (.pair child (.graph position) hne candidate) actual (outside input) ↔
+              ¬Bad parameter words disclosed actual input (outside input) at hkeep
+            simp only [stoppedTableReply, tableReply, hdecode, Option.elim_some, if_neg hcanonical, routedTableReply]
+            by_cases hk : Probe.keep (.pair child (.graph position) hne candidate) actual (outside input)
+            · rw [if_pos hk, if_neg (hkeep.mp hk)]
+            · rw [if_neg hk, if_pos (not_not.mp (fun hn => hk (hkeep.mpr hn)))]
+      | output parent =>
+          obtain ⟨position, hat, rfl, hinput⟩ := hspec
+          have hdecode := (decodePosition_some_iff parameter input position).mpr hat
+          have hkeep := hsafe (outside input)
+          change Probe.keep (.output (.graph position)) actual (outside input) ↔
+            ¬Bad parameter words disclosed actual input (outside input) at hkeep
+          simp only [stoppedTableReply, tableReply, hdecode, Option.elim_some, if_neg hinput, routedTableReply]
+          by_cases hk : Probe.keep (.output (.graph position)) actual (outside input)
+          · rw [if_pos hk, if_neg (hkeep.mp hk)]
+          · rw [if_neg hk, if_pos (not_not.mp (fun hn => hk (hkeep.mpr hn)))]
+
+theorem stoppedTableReply_route (parameter : PublicParameter) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known actual : Labels)
+    (hagrees : PublicAgreement words disclosed known actual)
+    (replies publicReplies : CanonicalGraphLabels)
+    (hreplies : ∀ position, ¬CanonicalCoordinate.Hidden words disclosed (.graph position) →
+      publicReplies position = replies position)
+    (outside : QueryImpl HashSpec Id) (input : HashInput) :
+    stoppedTableReply parameter words disclosed actual replies outside input =
+      routedTableReply publicReplies actual outside input (route parameter words disclosed known input) :=
+  stoppedTableReply_eq_routed parameter words disclosed actual replies publicReplies hreplies outside input _
+    (route_spec parameter words disclosed known actual hagrees input)
+
+end SphincsSecurity.Concrete.CanonicalProbeRouting
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/CheckedByteExecution.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/CheckedByteExecution.lean
new file mode 100644
index 000000000..159562f78
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/CheckedByteExecution.lean
@@ -0,0 +1,49 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.ResidualByteRun
+namespace SphincsSecurity.Concrete.ResidualByteFrontend
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting HiddenLabelObservation ResidualByteAction
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def checkedResult {Memory : Type} (reject : HashInput → HashOutput → Prop) (input : HashInput)
+    (result : Option HashOutput × Memory) : Option HashOutput × Memory :=
+  (result.1.bind (fun answer => if reject input answer then none else some answer), result.2)
+
+noncomputable def checkedHashQuery {inputs : Finset HashInput} (reject : HashInput → HashOutput → Prop)
+    (input : inputs) : OracleComp (World inputs) HashOutput := do
+  let answer ← hashQuery input
+  if reject input.val answer then liftM ((World inputs).query (.inl .stop)) else pure answer
+
+noncomputable def checkedTranslate (inputs : Finset HashInput) (reject : HashInput → HashOutput → Prop) :
+    QueryImpl OracleWorld (OracleComp (World inputs))
+  | .inl input => liftM ((World inputs).query (.inl (.random input)))
+  | .inr input => if hin : input ∈ inputs then checkedHashQuery reject ⟨input, hin⟩ else pure (0 : HashOutput)
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels) (actions : inputs → Action inputs)
+
+theorem observedRun_stop (actual : Labels) (seed : inputs → HashOutput) (state : State inputs) :
+    AdaptiveResidualLabels.observedRun (environment parameter inputs words disclosed known actions) actual seed
+      (liftM ((World inputs).query (.inl .stop)) : OracleComp (World inputs) HashOutput) state = pure (none, state) := by
+  simp only [AdaptiveResidualLabels.observedRun, AdaptiveResidualLabels.runWith, simulateQ_spec_query,
+    AdaptiveResidualLabels.observedImpl, environment, OptionT.run_mk, StateT.run_mk, SPMF.lift_pure, pure_bind]
+
+theorem observedRun_checkedHashQuery (reject : HashInput → HashOutput → Prop) (actual : Labels)
+    (seed : inputs → HashOutput) (input : inputs) (state : State inputs) :
+    AdaptiveResidualLabels.observedRun (environment parameter inputs words disclosed known actions) actual seed
+      (checkedHashQuery reject input) state =
+        pure (checkedResult reject input.val (hashQueryResult parameter inputs words disclosed known actions actual seed input state)) := by
+  rw [checkedHashQuery, observedRun_bind, observedRun_hashQuery, pure_bind]
+  generalize hresult : hashQueryResult parameter inputs words disclosed known actions actual seed input state = result
+  rcases result with ⟨answer, after⟩
+  cases answer with
+  | none => rfl
+  | some answer =>
+      dsimp only [Option.elim_some, checkedResult, Option.bind_some]
+      by_cases hreject : reject input.val answer
+      · simp only [if_pos hreject, observedRun_stop]
+      · simp only [if_neg hreject, AdaptiveResidualLabels.observedRun, AdaptiveResidualLabels.runWith_pure]
+
+end SphincsSecurity.Concrete.ResidualByteFrontend
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/PublicReferenceResidual.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/PublicReferenceResidual.lean
new file mode 100644
index 000000000..1275f6954
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/PublicReferenceResidual.lean
@@ -0,0 +1,101 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.CanonicalResidualQuery
+import SphincsSecurity.Proof.Ots.EncodingFamilyOracleSplit
+import SphincsSecurity.Proof.Base.UniformTableOverwrite
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+theorem layerMessagePosition_public (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (index : Index) (lay : Layer) :
+    ¬CanonicalCoordinate.Hidden words disclosed (.graph (layerMessagePosition index lay)) := by
+  unfold layerMessagePosition
+  split_ifs <;> simp only [CanonicalCoordinate.Hidden, not_false_eq_true]
+
+noncomputable def knownEncodingMessage (known : Labels) (position : EncodingPosition) : Digest :=
+  known (.graph (layerMessagePosition (referenceIndex position.lay position.tree position.leafIdx) position.lay))
+
+theorem knownEncodingMessage_eq (words : OtsReferenceWords) (disclosed : Index → FtsTree → FtsLeaf → Prop)
+    (known : Labels) (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (labels : CanonicalGraphLabels)
+    (hagrees : PublicAgreement words disclosed known (CanonicalCoordinate.value otsSecret ftsSecret labels)) :
+    knownEncodingMessage known = canonicalGraphMessage labels := by
+  funext position
+  exact hagrees _ (layerMessagePosition_public words disclosed _ _)
+
+noncomputable def knownEncodingCell (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (known : Labels) : EncodingRow → inputs :=
+  encodingInputCell parameter inputs hencoding ∘ referenceFamilyCell parameter (knownEncodingMessage known)
+
+theorem knownEncodingCell_injective (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (known : Labels) :
+    Function.Injective (knownEncodingCell parameter inputs hencoding known) :=
+  (encodingInputCell_injective parameter inputs hencoding).comp
+    (referenceFamilyCell_injective parameter (knownEncodingMessage known))
+
+theorem canonicalEncodingCell_eq_known (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (labels : CanonicalGraphLabels)
+    (hagrees : PublicAgreement words disclosed known (CanonicalCoordinate.value otsSecret ftsSecret labels)) :
+    canonicalEncodingCell parameter inputs hencoding labels = knownEncodingCell parameter inputs hencoding known := by
+  funext row
+  apply Subtype.ext
+  change encodingRetryInput parameter row.1 (canonicalGraphMessage labels row.1) row.2.val =
+    encodingRetryInput parameter row.1 (knownEncodingMessage known row.1) row.2.val
+  rw [knownEncodingMessage_eq words disclosed known otsSecret ftsSecret labels hagrees]
+
+noncomputable def canonicalReferenceResidual (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (labels : CanonicalGraphLabels)
+    (rows : CanonicalEncodingRows) (seed : inputs → HashOutput) : inputs → HashOutput :=
+  UniformTableSplit.overwrite (canonicalEncodingCell parameter inputs hencoding labels)
+    (canonicalEncodingCell_injective parameter inputs hencoding labels) rows seed
+
+noncomputable def knownReferenceResidual (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (known : Labels)
+    (rows : CanonicalEncodingRows) (seed : inputs → HashOutput) : inputs → HashOutput :=
+  UniformTableSplit.overwrite (knownEncodingCell parameter inputs hencoding known)
+    (knownEncodingCell_injective parameter inputs hencoding known) rows seed
+
+theorem canonicalReferenceResidual_eq_known (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (labels : CanonicalGraphLabels)
+    (hagrees : PublicAgreement words disclosed known (CanonicalCoordinate.value otsSecret ftsSecret labels))
+    (rows : CanonicalEncodingRows) (seed : inputs → HashOutput) :
+    canonicalReferenceResidual parameter inputs hencoding labels rows seed =
+      knownReferenceResidual parameter inputs hencoding known rows seed := by
+  unfold canonicalReferenceResidual knownReferenceResidual
+  congr 1
+  exact canonicalEncodingCell_eq_known parameter inputs hencoding words disclosed known otsSecret ftsSecret labels hagrees
+
+theorem knownEncodingCell_not_structural (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (known : Labels)
+    (input : inputs) (position : Position) (hat : AtPosition parameter input.val position) :
+    input ∉ Set.range (knownEncodingCell parameter inputs hencoding known) := by
+  rintro ⟨row, heq⟩
+  have hencoding : AtEncodingPosition parameter
+      (knownEncodingCell parameter inputs hencoding known row).val row.1 := ⟨_, rfl⟩
+  rw [heq] at hencoding
+  exact hencoding.not_atPosition position hat
+
+theorem programmedReferenceResidual_outside (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (labels : CanonicalGraphLabels)
+    (hagrees : PublicAgreement words disclosed known (CanonicalCoordinate.value otsSecret ftsSecret labels))
+    (rows : CanonicalEncodingRows) (seed : inputs → HashOutput) (input : HashInput)
+    (houtside : decodePosition parameter input = none) :
+    programmedHash parameter otsSecret ftsSecret labels
+        (finiteHashAnswer ∅ inputs (canonicalReferenceResidual parameter inputs hencoding labels rows seed)) input =
+      finiteHashAnswer ∅ inputs (knownReferenceResidual parameter inputs hencoding known rows seed) input := by
+  rw [canonicalReferenceResidual_eq_known parameter inputs hencoding words disclosed known otsSecret ftsSecret labels hagrees]
+  simp only [programmedHash, houtside, Option.elim_none]
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/PublicResidualLookup.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/PublicResidualLookup.lean
new file mode 100644
index 000000000..48fcc380f
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/PublicResidualLookup.lean
@@ -0,0 +1,55 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.PublicReferenceResidual
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def knownEncodingRowAt (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (known : Labels) (input : inputs) : Option EncodingRow :=
+  letI : Decidable (∃ row, knownEncodingCell parameter inputs hencoding known row = input) := Classical.propDecidable _
+  if h : ∃ row, knownEncodingCell parameter inputs hencoding known row = input then some h.choose else none
+
+theorem knownEncodingRowAt_some (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (known : Labels) (input : inputs) (row : EncodingRow) :
+    knownEncodingRowAt parameter inputs hencoding known input = some row ↔
+      knownEncodingCell parameter inputs hencoding known row = input := by
+  unfold knownEncodingRowAt
+  split
+  · rename_i h
+    constructor
+    · intro heq
+      exact Option.some.inj heq ▸ h.choose_spec
+    · intro heq
+      exact congrArg some (knownEncodingCell_injective parameter inputs hencoding known (h.choose_spec.trans heq.symm))
+  · rename_i h
+    constructor
+    · simp
+    · intro heq
+      exact (h ⟨row, heq⟩).elim
+
+theorem knownEncodingRowAt_none (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (known : Labels) (input : inputs) :
+    knownEncodingRowAt parameter inputs hencoding known input = none ↔
+      input ∉ Set.range (knownEncodingCell parameter inputs hencoding known) := by
+  constructor
+  · intro hnone
+    rintro ⟨row, hrow⟩
+    have hsome := (knownEncodingRowAt_some parameter inputs hencoding known input row).mpr hrow
+    rw [hnone] at hsome
+    cases hsome
+  · intro hout
+    cases h : knownEncodingRowAt parameter inputs hencoding known input with
+    | none => rfl
+    | some row => exact (hout ⟨row, (knownEncodingRowAt_some parameter inputs hencoding known input row).mp h⟩).elim
+
+theorem knownEncodingRowAt_structural (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (known : Labels)
+    (input : inputs) (position : Position) (hat : AtPosition parameter input.val position) :
+    knownEncodingRowAt parameter inputs hencoding known input = none :=
+  (knownEncodingRowAt_none parameter inputs hencoding known input).mpr
+    (knownEncodingCell_not_structural parameter inputs hencoding known input position hat)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualByteAction.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualByteAction.lean
new file mode 100644
index 000000000..48a81338b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualByteAction.lean
@@ -0,0 +1,26 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.CanonicalResidualRouting
+import SphincsSecurity.Proof.Residual.PublicResidualLookup
+namespace SphincsSecurity.Concrete.ResidualByteAction
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting HiddenLabelObservation
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+inductive Action (inputs : Finset HashInput) where
+  | known (answer : HashOutput)
+  | read (input : inputs)
+  | probe (input : inputs) (test : Probe CanonicalCoordinate)
+
+def Local {inputs : Finset HashInput} (input : inputs) : Action inputs → Prop
+  | .known _ => True
+  | .read row => row = input
+  | .probe row _ => row = input
+
+noncomputable def eval {inputs : Finset HashInput} (labels : Labels) (seed : inputs → HashOutput) : Action inputs → Option HashOutput
+  | .known answer => some answer
+  | .read input => some (seed input)
+  | .probe input test => if test.keep labels (seed input) then some (seed input) else none
+
+end SphincsSecurity.Concrete.ResidualByteAction
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualByteCandidates.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualByteCandidates.lean
new file mode 100644
index 000000000..7b93cc05c
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualByteCandidates.lean
@@ -0,0 +1,111 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Ots.PrefixByteAction
+import SphincsSecurity.Proof.Residual.ResidualByteExecution
+namespace SphincsSecurity.Concrete.CanonicalProbeRouting
+
+theorem charge_probes_mono (parameter : PublicParameter) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels) (input : HashInput)
+    (memory : ExternalMemory) : memory.probes ≤ (charge parameter words disclosed known input memory).probes := by
+  unfold charge
+  exact Nat.le_add_right _ _
+
+end SphincsSecurity.Concrete.CanonicalProbeRouting
+
+namespace SphincsSecurity.Concrete.ResidualByteAction
+
+open CanonicalProbeRouting HiddenLabelObservation
+attribute [local instance] Classical.propDecidable
+
+theorem freshPrefix_probe_route (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels) (publicReplies : CanonicalGraphLabels)
+    (selections : ReferenceFamily) (rows : CanonicalEncodingRows) (input row : inputs)
+    (test : Probe CanonicalCoordinate)
+    (haction : freshPrefix parameter inputs hencoding words disclosed known publicReplies selections rows input = .probe row test) :
+    route parameter words disclosed known input.val = .probe test := by
+  unfold freshPrefix at haction
+  cases hroute : route parameter words disclosed known input.val with
+  | outside =>
+      rw [hroute] at haction
+      cases hrow : knownEncodingRowAt parameter inputs hencoding known input with
+      | none => simp only [hrow, Option.elim_none] at haction; cases haction
+      | some index => simp only [hrow, Option.elim_some] at haction; split at haction <;> cases haction
+  | canonical position => rw [hroute] at haction; cases haction
+  | probe actual =>
+      rw [hroute] at haction
+      cases haction
+      rfl
+
+end SphincsSecurity.Concrete.ResidualByteAction
+
+namespace SphincsSecurity.Concrete.ResidualByteFrontend
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting HiddenLabelObservation ResidualByteAction
+open AdaptiveResidualLabels hiding World State Environment
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+def HiddenCandidateBound (words : OtsReferenceWords) (disclosed : Index → FtsTree → FtsLeaf → Prop)
+    {inputs : Finset HashInput} (state : State inputs) : Prop :=
+  ∀ coordinate, CanonicalCoordinate.Hidden words disclosed coordinate →
+    2 ^ digestBits ≤ (state.candidates coordinate).card + state.memory.probes
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels) (actions : inputs → Action inputs)
+
+theorem hashQueryResult_candidateCost_mono (actual : Labels) (seed : inputs → HashOutput)
+    (input : inputs) (state : State inputs)
+    (hcharge : ∀ row test, actions input = .probe row test → route parameter words disclosed known input.val = .probe test)
+    (coordinate : CanonicalCoordinate) :
+    (state.candidates coordinate).card + state.memory.probes ≤
+      ((hashQueryResult parameter inputs words disclosed known actions actual seed input state).2.candidates coordinate).card +
+        (hashQueryResult parameter inputs words disclosed known actions actual seed input state).2.memory.probes := by
+  have hmono := charge_probes_mono parameter words disclosed known input.val state.memory
+  cases hcache : state.memory.cache input.val with
+  | some answer =>
+      simpa only [hashQueryResult, prepare, hcache, executeResult] using Nat.add_le_add_left hmono _
+  | none =>
+      cases haction : actions input with
+      | known answer =>
+          simpa only [hashQueryResult, prepare, hcache, haction, executeResult, storeReply] using Nat.add_le_add_left hmono _
+      | read row =>
+          simpa only [hashQueryResult, prepare, hcache, haction, executeResult, readState, environment, storeReply] using
+            Nat.add_le_add_left hmono _
+      | probe row test =>
+          have hpaid : (charge parameter words disclosed known input.val state.memory).probes = state.memory.probes + 1 := by
+            simp only [charge, hcache, hcharge row test haction]
+          simp only [hashQueryResult, prepare, hcache, haction, executeResult]
+          cases hrow : state.rows row with
+          | some answer =>
+              simp only [readState, environment, storeReply, hpaid]
+              omega
+          | none =>
+              dsimp only
+              split
+              · have hcard := test.card_lower state.candidates (seed row) coordinate
+                simp only [probeState, environment, storeReply, hpaid]
+                omega
+              · simp only [stoppedState, environment, hpaid]
+                omega
+
+theorem hashQueryResult_hiddenCandidateBound (actual : Labels) (seed : inputs → HashOutput)
+    (input : inputs) (state : State inputs) (hbound : HiddenCandidateBound words disclosed state)
+    (hcharge : ∀ row test, actions input = .probe row test → route parameter words disclosed known input.val = .probe test) :
+    HiddenCandidateBound words disclosed
+      (hashQueryResult parameter inputs words disclosed known actions actual seed input state).2 := by
+  intro coordinate hhidden
+  exact (hbound coordinate hhidden).trans
+    (hashQueryResult_candidateCost_mono parameter inputs words disclosed known actions actual seed input state hcharge coordinate)
+
+omit actions in
+theorem prefixHashQueryResult_hiddenCandidateBound (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+    (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+    (actual : Labels) (seed : inputs → HashOutput) (input : inputs) (state : State inputs)
+    (hbound : HiddenCandidateBound words disclosed state) :
+    HiddenCandidateBound words disclosed
+      (hashQueryResult parameter inputs words disclosed known
+        (freshPrefix parameter inputs hencoding words disclosed known publicReplies selections rows) actual seed input state).2 :=
+  hashQueryResult_hiddenCandidateBound parameter inputs words disclosed known _ actual seed input state hbound
+    (freshPrefix_probe_route parameter inputs hencoding words disclosed known publicReplies selections rows input)
+
+end SphincsSecurity.Concrete.ResidualByteFrontend
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualByteCheckedHazard.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualByteCheckedHazard.lean
new file mode 100644
index 000000000..5f4b70a9c
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualByteCheckedHazard.lean
@@ -0,0 +1,76 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.ResidualByteHazard
+namespace SphincsSecurity.Concrete.ResidualByteFrontend
+
+open _root_.OracleComp OracleSpec ENNReal CanonicalProbeRouting HiddenLabelObservation ResidualByteAction
+open AdaptiveResidualLabels hiding World State Environment
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+theorem checkedResult_stopped_iff {Memory : Type} (reject : HashInput → HashOutput → Prop) (input : HashInput)
+    (result : Option HashOutput × Memory) :
+    (checkedResult reject input result).1 = none ↔ result.1 = none ∨ ReturnedMatch reject input result := by
+  rcases result with ⟨answer, memory⟩
+  cases answer with
+  | none => simp [checkedResult, ReturnedMatch]
+  | some answer =>
+      by_cases hreject : reject input answer <;> simp [checkedResult, returnedMatch_some, hreject]
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels) (actions : inputs → Action inputs)
+
+theorem lazyRun_checkedHashQuery (reject : HashInput → HashOutput → Prop) (input : inputs) (state : State inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty) :
+    lazyRun (environment parameter inputs words disclosed known actions) (checkedHashQuery reject input) state =
+      checkedResult reject input.val <$>
+        lazyRun (environment parameter inputs words disclosed known actions) (hashQuery input) state := by
+  rw [← run_erasure _ _ state ha, ← run_erasure _ _ state ha]
+  simp only [map_bind, observedRun_checkedHashQuery, observedRun_hashQuery, map_pure]
+
+theorem prob_checkedHashQuery_stop_le_add (reject : HashInput → HashOutput → Prop) (input : inputs) (state : State inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty) :
+    Pr[fun result => result.1 = none |
+      lazyRun (environment parameter inputs words disclosed known actions) (checkedHashQuery reject input) state] ≤
+      Pr[fun result => result.1 = none |
+        lazyRun (environment parameter inputs words disclosed known actions) (hashQuery input) state] +
+      Pr[ReturnedMatch reject input.val |
+        lazyRun (environment parameter inputs words disclosed known actions) (hashQuery input) state] := by
+  rw [lazyRun_checkedHashQuery parameter inputs words disclosed known actions reject input state ha, probEvent_map]
+  simp only [Function.comp_def, checkedResult_stopped_iff]
+  exact probEvent_or_le _ _ _
+
+omit actions in
+theorem prob_checkedPrefixHashQuery_stop_le (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+    (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+    (hselect : ∀ position, FirstSuccessTable.select decodeEncodingOutput (fun counter => rows (position, counter)) = selections position)
+    (input : inputs) (state : State inputs) (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : RowsCovered inputs state) (hbound : HiddenCandidateBound words disclosed state)
+    (hclean : ReplyClean (PublicEncodingMatch.Match parameter (knownEncodingMessage known) words selections) state.memory.cache) :
+    Pr[fun result => result.1 = none |
+      lazyRun (prefixEnvironment parameter inputs hencoding words disclosed known publicReplies selections rows)
+        (checkedHashQuery (PublicEncodingMatch.Match parameter (knownEncodingMessage known) words selections) input) state] ≤
+      probeHazard state.memory.probes := by
+  apply (prob_checkedHashQuery_stop_le_add parameter inputs words disclosed known _ _ input state ha).trans
+  by_cases hexists : ∃ position, AtEncodingPosition parameter input.val position
+  · obtain ⟨position, hat⟩ := hexists
+    have hzero := prob_hashQuery_stop_le parameter inputs words disclosed known
+      (freshPrefix parameter inputs hencoding words disclosed known publicReplies selections rows) input state 0 hcovered
+      (freshPrefix_local parameter inputs hencoding words disclosed known publicReplies selections rows input)
+      (fun row test hprobe => by
+        rcases prefix_encoding_actions parameter inputs words disclosed known hencoding publicReplies selections rows hselect input position hat with
+          ⟨answer, hknown, _⟩ | hread
+        · rw [hknown] at hprobe; cases hprobe
+        · rw [hread] at hprobe; cases hprobe)
+    have hencodingRisk := prob_prefixHashQuery_encodingMatch_le parameter inputs words disclosed known hencoding publicReplies selections rows
+      hselect input state hcovered hclean
+    exact (add_le_add hzero hencodingRisk).trans (by simpa only [zero_add] using digest_inverse_le_probeHazard state.memory.probes)
+  · have hzero : Pr[ReturnedMatch (PublicEncodingMatch.Match parameter (knownEncodingMessage known) words selections) input.val |
+        lazyRun (prefixEnvironment parameter inputs hencoding words disclosed known publicReplies selections rows) (hashQuery input) state] = 0 := by
+      apply probEvent_eq_zero
+      rintro result _ ⟨answer, _, position, hat, _⟩
+      exact hexists ⟨position, hat⟩
+    rw [hzero, add_zero]
+    exact prob_prefixHashQuery_stop_le parameter inputs words disclosed known hencoding publicReplies selections rows input state ha hcovered hbound
+
+end SphincsSecurity.Concrete.ResidualByteFrontend
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualByteCorrespondence.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualByteCorrespondence.lean
new file mode 100644
index 000000000..8440c7093
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualByteCorrespondence.lean
@@ -0,0 +1,91 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.ResidualByteExecution
+namespace SphincsSecurity.Concrete.ResidualByteFrontend
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting HiddenLabelObservation ResidualByteAction
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+def CacheMatches (oracle : HashInput → HashOutput) (cache : ExternalCache) : Prop :=
+  ∀ input answer, cache input = some answer → answer = oracle input
+
+theorem cacheMatches_store (oracle : HashInput → HashOutput) (cache : ExternalCache)
+    (hmatches : CacheMatches oracle cache) (input : HashInput) :
+    CacheMatches oracle (Function.update cache input (some (oracle input))) := by
+  intro other answer hcache
+  by_cases heq : other = input
+  · subst other
+    rw [Function.update_self] at hcache
+    exact (Option.some.inj hcache).symm
+  · rw [Function.update_of_ne heq] at hcache
+    exact hmatches other answer hcache
+
+noncomputable def fixedAnswer (parameter : PublicParameter) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (actual : Labels)
+    (oracle : HashInput → HashOutput) (input : HashInput) : Option HashOutput :=
+  if CanonicalProbeRouting.Bad parameter words disclosed actual input (oracle input) then none else some (oracle input)
+
+noncomputable def fixedStep (parameter : PublicParameter) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known actual : Labels)
+    (oracle : HashInput → HashOutput) (input : HashInput) (memory : ExternalMemory) : Option HashOutput × ExternalMemory :=
+  let paid := charge parameter words disclosed known input memory
+  let answer := fixedAnswer parameter words disclosed actual oracle input
+  (answer, answer.elim paid (fun answer => storeReply paid input answer))
+
+theorem fixedStep_preserves (parameter : PublicParameter) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known actual : Labels)
+    (oracle : HashInput → HashOutput) (input : HashInput) (memory : ExternalMemory)
+    (hmatches : CacheMatches oracle memory.cache) (hclean : CacheClean parameter words disclosed actual memory.cache) :
+    let after := (fixedStep parameter words disclosed known actual oracle input memory).2
+    CacheMatches oracle after.cache ∧ CacheClean parameter words disclosed actual after.cache ∧
+      after.hashCalls = memory.hashCalls + 1 := by
+  unfold fixedStep fixedAnswer
+  split
+  · exact ⟨hmatches, hclean, rfl⟩
+  · rename_i hsafe
+    exact ⟨cacheMatches_store oracle memory.cache hmatches input,
+      cacheClean_store parameter words disclosed actual memory.cache hclean input (oracle input) hsafe, rfl⟩
+
+theorem fixedStep_hashCalls (parameter : PublicParameter) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known actual : Labels)
+    (oracle : HashInput → HashOutput) (input : HashInput) (memory : ExternalMemory) :
+    (fixedStep parameter words disclosed known actual oracle input memory).2.hashCalls = memory.hashCalls + 1 := by
+  unfold fixedStep
+  cases fixedAnswer parameter words disclosed actual oracle input <;> rfl
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels) (actions : inputs → Action inputs)
+
+theorem publicCachedReply_eq_fixed (actual : Labels) (seed : inputs → HashOutput)
+    (oracle : HashInput → HashOutput) (input : inputs) (memory : ExternalMemory)
+    (hmatches : CacheMatches oracle memory.cache) (hclean : CacheClean parameter words disclosed actual memory.cache)
+    (hfresh : ResidualByteAction.eval actual seed
+      (actions input) =
+        fixedAnswer parameter words disclosed actual oracle input.val) :
+    publicCachedReply inputs actions actual seed input memory =
+      fixedAnswer parameter words disclosed actual oracle input.val := by
+  cases hcache : memory.cache input.val with
+  | none => simpa only [publicCachedReply, hcache, Option.elim_none] using hfresh
+  | some answer =>
+      have hsafe := hclean input.val answer hcache
+      have heq := hmatches input.val answer hcache
+      rw [heq] at hsafe
+      simp only [publicCachedReply, hcache, Option.elim_some, fixedAnswer, if_neg hsafe, heq]
+
+theorem hashQueryResult_eq_fixed (actual : Labels) (seed : inputs → HashOutput)
+    (oracle : HashInput → HashOutput) (input : inputs) (state : State inputs)
+    (hcovered : RowsCovered inputs state) (hlocal : Local input (actions input)) (hmatches : CacheMatches oracle state.memory.cache)
+    (hclean : CacheClean parameter words disclosed actual state.memory.cache)
+    (hfresh : ResidualByteAction.eval actual seed
+      (actions input) =
+        fixedAnswer parameter words disclosed actual oracle input.val) :
+    let result := hashQueryResult parameter inputs words disclosed known actions actual seed input state
+    (result.1, result.2.memory) = fixedStep parameter words disclosed known actual oracle input.val state.memory := by
+  dsimp only
+  rw [hashQueryResult_project parameter inputs words disclosed known actions actual seed input state hcovered hlocal,
+    publicCachedReply_eq_fixed parameter inputs words disclosed actions actual seed
+      oracle input state.memory hmatches hclean hfresh]
+  rfl
+
+end SphincsSecurity.Concrete.ResidualByteFrontend
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualByteExecution.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualByteExecution.lean
new file mode 100644
index 000000000..d462eae09
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualByteExecution.lean
@@ -0,0 +1,180 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.ResidualByteFrontend
+namespace SphincsSecurity.Concrete.ResidualByteFrontend
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting HiddenLabelObservation ResidualByteAction
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels) (actions : inputs → Action inputs)
+
+noncomputable def executeResult (actual : Labels) (seed : inputs → HashOutput) (state : State inputs) :
+    Action inputs → Option HashOutput × State inputs
+  | .known answer => (some answer, state)
+  | .read input => (some (seed input), AdaptiveResidualLabels.readState
+      (environment parameter inputs words disclosed known actions) state input (seed input))
+  | .probe input test =>
+      match state.rows input with
+      | some answer => (some answer, AdaptiveResidualLabels.readState
+          (environment parameter inputs words disclosed known actions) state input answer)
+      | none => if test.keep actual (seed input) then
+          (some (seed input), AdaptiveResidualLabels.probeState
+            (environment parameter inputs words disclosed known actions) state input test (seed input))
+        else (none, AdaptiveResidualLabels.stoppedState
+          (environment parameter inputs words disclosed known actions) state input test)
+
+theorem observedRun_execute (actual : Labels) (seed : inputs → HashOutput) (state : State inputs) (action : Action inputs) :
+    AdaptiveResidualLabels.observedRun (environment parameter inputs words disclosed known actions) actual seed
+      (execute action) state = pure (executeResult parameter inputs words disclosed known actions actual seed state action) := by
+  cases action with
+  | known answer =>
+      simp only [execute, AdaptiveResidualLabels.observedRun, AdaptiveResidualLabels.runWith_pure, executeResult]
+  | read input =>
+      simp only [execute, AdaptiveResidualLabels.observedRun, AdaptiveResidualLabels.runWith, simulateQ_spec_query,
+        AdaptiveResidualLabels.observedImpl, OptionT.run_mk, StateT.run_mk, executeResult]
+  | probe input test =>
+      simp only [execute, AdaptiveResidualLabels.observedRun, AdaptiveResidualLabels.runWith, simulateQ_spec_query,
+        AdaptiveResidualLabels.observedImpl, OptionT.run_mk, StateT.run_mk, executeResult]
+      dsimp only [OracleSpec.Range, World, AdaptiveResidualLabels.World, OracleSpec.add_apply_inr,
+        AdaptiveResidualLabels.ResidualSpec]
+      cases hrow : state.rows input with
+      | none => by_cases hkeep : test.keep actual (seed input) <;> simp only [hkeep, if_true, if_false]
+      | some answer => rfl
+
+noncomputable def hashQueryResult (actual : Labels) (seed : inputs → HashOutput) (input : inputs) (state : State inputs) :
+    Option HashOutput × State inputs :=
+  let prepared := prepare parameter inputs words disclosed known actions input state.memory
+  executeResult parameter inputs words disclosed known actions actual seed { state with memory := prepared.2 } prepared.1
+
+theorem observedRun_hashQuery (actual : Labels) (seed : inputs → HashOutput) (input : inputs) (state : State inputs) :
+    AdaptiveResidualLabels.observedRun (environment parameter inputs words disclosed known actions) actual seed
+      (hashQuery input) state = pure (hashQueryResult parameter inputs words disclosed known actions actual seed input state) := by
+  rw [hashQuery, observedRun_prepare_bind, observedRun_execute]
+  rfl
+
+omit parameter words disclosed known actions in
+noncomputable def delivered (input : inputs) (memory : ExternalMemory) (answer : Option HashOutput) : ExternalMemory :=
+  answer.elim memory (fun answer => storeReply memory input.val answer)
+
+noncomputable def publicCachedReply (actual : Labels) (seed : inputs → HashOutput) (input : inputs) (memory : ExternalMemory) :
+    Option HashOutput :=
+  (memory.cache input.val).elim
+    (ResidualByteAction.eval actual seed (actions input)) some
+
+theorem hashQueryResult_project (actual : Labels) (seed : inputs → HashOutput) (input : inputs) (state : State inputs)
+    (hcovered : RowsCovered inputs state) (hlocal : Local input (actions input)) :
+    let result := hashQueryResult parameter inputs words disclosed known actions actual seed input state
+    let answer := publicCachedReply inputs actions actual seed input state.memory
+    (result.1, result.2.memory) = (answer, delivered inputs input
+      (charge parameter words disclosed known input.val state.memory) answer) := by
+  dsimp only
+  cases hcache : state.memory.cache input.val with
+  | some answer =>
+      simp only [hashQueryResult, prepare, hcache, executeResult, publicCachedReply, Option.elim_some, delivered]
+      congr 1
+      unfold storeReply charge
+      simp only [← hcache, Function.update_eq_self]
+  | none =>
+      have hrow := rowsCovered_fresh inputs state hcovered input hcache
+      simp only [hashQueryResult, prepare, hcache, publicCachedReply, Option.elim_none]
+      cases haction : actions input with
+      | known answer => rfl
+      | read row =>
+          have heq : row = input := by simpa only [haction, Local] using hlocal
+          subst row
+          rfl
+      | probe row test =>
+          have heq : row = input := by simpa only [haction, Local] using hlocal
+          subst row
+          simp only [executeResult, hrow, ResidualByteAction.eval]
+          split <;> rfl
+
+theorem hashQueryResult_hashCalls (actual : Labels) (seed : inputs → HashOutput) (input : inputs) (state : State inputs) :
+    (hashQueryResult parameter inputs words disclosed known actions actual seed input state).2.memory.hashCalls =
+      state.memory.hashCalls + 1 := by
+  have h := prepare_hashCalls parameter inputs words disclosed known actions input state.memory
+  unfold hashQueryResult
+  generalize hprepared : prepare parameter inputs words disclosed known actions input state.memory = prepared at *
+  rcases prepared with ⟨action, memory⟩
+  cases action with
+  | known answer => exact h
+  | read input => exact h
+  | probe input test =>
+      dsimp only [executeResult]
+      cases hrow : state.rows input with
+      | none =>
+          dsimp only
+          split <;> exact h
+      | some answer =>
+          dsimp only
+          exact h
+
+omit parameter words disclosed known actions in
+theorem rowsCovered_store (state : State inputs) (hcovered : RowsCovered inputs state)
+    (candidates : CanonicalCoordinate → Finset Digest) (input : inputs) (answer : HashOutput) :
+    RowsCovered inputs ⟨candidates, Function.update state.rows input (some answer), storeReply state.memory input.val answer⟩ := by
+  intro other output hrow
+  dsimp only at hrow
+  by_cases heq : other = input
+  · subst other
+    simp only [Function.update_self, Option.some.injEq] at hrow
+    subst output
+    exact Function.update_self ..
+  · have hval : other.val ≠ input.val := fun h => heq (Subtype.ext h)
+    rw [Function.update_of_ne heq] at hrow
+    exact (Function.update_of_ne hval _ _).trans (hcovered other output hrow)
+
+omit parameter words disclosed known actions in
+theorem rowsCovered_store_public (state : State inputs) (hcovered : RowsCovered inputs state)
+    (input : inputs) (hfresh : state.rows input = none) (answer : HashOutput) :
+    RowsCovered inputs { state with memory := storeReply state.memory input.val answer } := by
+  intro other output hrow
+  by_cases heq : other = input
+  · subst other
+    rw [hfresh] at hrow
+    cases hrow
+  · have hval : other.val ≠ input.val := fun h => heq (Subtype.ext h)
+    exact (Function.update_of_ne hval _ _).trans (hcovered other output hrow)
+
+theorem prepare_rowsCovered (state : State inputs) (hcovered : RowsCovered inputs state) (input : inputs) :
+    RowsCovered inputs { state with memory :=
+      (prepare parameter inputs words disclosed known actions input state.memory).2 } := by
+  unfold prepare
+  cases hcache : state.memory.cache input.val with
+  | some answer => exact hcovered
+  | none =>
+      have hrow := rowsCovered_fresh inputs state hcovered input hcache
+      cases actions input with
+      | known answer =>
+          exact rowsCovered_store_public inputs
+            { state with memory := charge parameter words disclosed known input.val state.memory } hcovered input hrow answer
+      | read _ => exact hcovered
+      | probe _ _ => exact hcovered
+
+theorem executeResult_rowsCovered (actual : Labels) (seed : inputs → HashOutput) (state : State inputs)
+    (hcovered : RowsCovered inputs state) (action : Action inputs) :
+    RowsCovered inputs
+      (executeResult parameter inputs words disclosed known actions actual seed state action).2 := by
+  cases action with
+  | known answer => exact hcovered
+  | read input => exact rowsCovered_store inputs state hcovered state.candidates input (seed input)
+  | probe input test =>
+      simp only [executeResult]
+      cases hrow : state.rows input with
+      | some answer => exact rowsCovered_store inputs state hcovered state.candidates input answer
+      | none =>
+          dsimp only
+          split
+          · exact rowsCovered_store inputs state hcovered (test.restrict state.candidates (seed input)) input (seed input)
+          · exact hcovered
+
+theorem hashQueryResult_rowsCovered (actual : Labels) (seed : inputs → HashOutput) (state : State inputs)
+    (hcovered : RowsCovered inputs state) (input : inputs) :
+    RowsCovered inputs
+      (hashQueryResult parameter inputs words disclosed known actions actual seed input state).2 :=
+  executeResult_rowsCovered parameter inputs words disclosed known actions actual seed _
+    (prepare_rowsCovered parameter inputs words disclosed known actions state hcovered input) _
+
+end SphincsSecurity.Concrete.ResidualByteFrontend
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualByteFrontend.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualByteFrontend.lean
new file mode 100644
index 000000000..23f81bb67
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualByteFrontend.lean
@@ -0,0 +1,100 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.AdaptiveResidualLabels
+import SphincsSecurity.Proof.Hypertree.CanonicalProbeCache
+import SphincsSecurity.Proof.Residual.ResidualByteAction
+namespace SphincsSecurity.Concrete.ResidualByteFrontend
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting HiddenLabelObservation ResidualByteAction
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+inductive Control (inputs : Finset HashInput) where
+  | prepare (input : inputs)
+  | random (input : unifSpec.Domain)
+  | account (cost : Nat)
+  | stop
+
+abbrev ControlSpec (inputs : Finset HashInput) : OracleSpec (Control inputs)
+  | .prepare _ => Action inputs
+  | .random input => unifSpec.Range input
+  | .account _ => Unit
+  | .stop => HashOutput
+
+abbrev World (inputs : Finset HashInput) := AdaptiveResidualLabels.World (ControlSpec inputs) CanonicalCoordinate inputs
+abbrev State (inputs : Finset HashInput) := AdaptiveResidualLabels.State CanonicalCoordinate inputs ExternalMemory
+
+noncomputable def execute {inputs : Finset HashInput} : Action inputs → OracleComp (World inputs) HashOutput
+  | .known answer => pure answer
+  | .read input => liftM ((World inputs).query (.inr (.read input)))
+  | .probe input test => liftM ((World inputs).query (.inr (.probe input test)))
+
+noncomputable def hashQuery {inputs : Finset HashInput} (input : inputs) : OracleComp (World inputs) HashOutput := do
+  let action ← liftM ((World inputs).query (.inl (.prepare input)))
+  execute action
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels) (actions : inputs → Action inputs)
+
+noncomputable def prepare (input : inputs) (memory : ExternalMemory) : Action inputs × ExternalMemory :=
+  let paid := charge parameter words disclosed known input.val memory
+  match memory.cache input.val with
+  | some answer => (.known answer, paid)
+  | none =>
+      let action := actions input
+      match action with
+      | .known answer => (action, storeReply paid input.val answer)
+      | _ => (action, paid)
+
+noncomputable def environment : AdaptiveResidualLabels.Environment (ControlSpec inputs) CanonicalCoordinate inputs ExternalMemory where
+  auxiliary state input := match input with
+    | .prepare input =>
+        let prepared := prepare parameter inputs words disclosed known actions input state.memory
+        PMF.pure (some prepared.1, prepared.2)
+    | .random input => (PMF.uniformOfFintype (unifSpec.Range input)).map (fun answer => (some answer, state.memory))
+    | .account cost => PMF.pure (some (), { state.memory with hashCalls := state.memory.hashCalls + cost })
+    | .stop => PMF.pure (none, state.memory)
+  rowAnswer memory input answer := storeReply memory input.val answer
+  probeAnswer memory input _ answer := storeReply memory input.val answer
+  probeStop memory _ _ := memory
+  disclosure memory _ _ := memory
+
+omit parameter words disclosed known actions in
+def RowsCovered (state : State inputs) : Prop :=
+  ∀ input answer, state.rows input = some answer → state.memory.cache input.val = some answer
+
+omit parameter words disclosed known actions in
+theorem rowsCovered_fresh (state : State inputs) (hcovered : RowsCovered inputs state) (input : inputs)
+    (hfresh : state.memory.cache input.val = none) : state.rows input = none := by
+  cases hrow : state.rows input with
+  | none => rfl
+  | some answer =>
+      have h := hcovered input answer hrow
+      rw [hfresh] at h
+      cases h
+
+theorem prepare_cached (input : inputs) (memory : ExternalMemory) (answer : HashOutput)
+    (hcache : memory.cache input.val = some answer) :
+    prepare parameter inputs words disclosed known actions input memory =
+      (.known answer, charge parameter words disclosed known input.val memory) := by
+  simp only [prepare, hcache]
+
+theorem prepare_hashCalls (input : inputs) (memory : ExternalMemory) :
+    (prepare parameter inputs words disclosed known actions input memory).2.hashCalls = memory.hashCalls + 1 := by
+  unfold prepare
+  cases memory.cache input.val with
+  | some answer => rfl
+  | none => cases actions input <;> rfl
+
+theorem observedRun_prepare_bind {Result : Type} (actual : Labels) (seed : inputs → HashOutput)
+    (input : inputs) (next : Action inputs → OracleComp (World inputs) Result) (state : State inputs) :
+    AdaptiveResidualLabels.observedRun (environment parameter inputs words disclosed known actions) actual seed
+      (liftM ((World inputs).query (.inl (.prepare input))) >>= next) state =
+        let prepared := prepare parameter inputs words disclosed known actions input state.memory
+        AdaptiveResidualLabels.observedRun (environment parameter inputs words disclosed known actions) actual seed
+          (next prepared.1) { state with memory := prepared.2 } := by
+  rw [AdaptiveResidualLabels.observedRun, AdaptiveResidualLabels.runWith_query_bind]
+  simp only [AdaptiveResidualLabels.observedImpl, environment, OptionT.run_mk, StateT.run_mk,
+    SPMF.lift_pure, pure_bind, Option.elim_some, AdaptiveResidualLabels.observedRun]
+
+end SphincsSecurity.Concrete.ResidualByteFrontend
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualByteHazard.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualByteHazard.lean
new file mode 100644
index 000000000..a5a7b50f1
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualByteHazard.lean
@@ -0,0 +1,120 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.AdaptiveHiddenHazard
+import SphincsSecurity.Proof.Ots.PrefixEncodingRisk
+import SphincsSecurity.Proof.Residual.ResidualByteCandidates
+namespace SphincsSecurity.Concrete.ResidualByteFrontend
+
+open _root_.OracleComp OracleSpec ENNReal CanonicalProbeRouting HiddenLabelObservation ResidualByteAction
+open AdaptiveResidualLabels hiding World State Environment
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def probeHazard (probes : Nat) : ENNReal :=
+  1 - (1 - ((2 ^ digestBits - probes : Nat) : ENNReal)⁻¹) ^ 2
+
+theorem digest_inverse_le_probeHazard (probes : Nat) :
+    (Fintype.card Digest : ENNReal)⁻¹ ≤ probeHazard probes := by
+  have hcard : Fintype.card Digest = 2 ^ digestBits := card_bitVec digestBits
+  have hone : (Fintype.card Digest : ENNReal)⁻¹ ≤ 1 := by
+    rw [hcard]
+    norm_num [digestBits]
+  have hinv : (Fintype.card Digest : ENNReal)⁻¹ ≤ ((2 ^ digestBits - probes : Nat) : ENNReal)⁻¹ := by
+    apply ENNReal.inv_le_inv.mpr
+    exact_mod_cast (show 2 ^ digestBits - probes ≤ Fintype.card Digest by rw [hcard]; exact Nat.sub_le _ _)
+  have hsquare : (1 - ((2 ^ digestBits - probes : Nat) : ENNReal)⁻¹) ^ 2 ≤
+      1 - (Fintype.card Digest : ENNReal)⁻¹ := by
+    rw [pow_two]
+    calc
+      _ ≤ 1 * (1 - ((2 ^ digestBits - probes : Nat) : ENNReal)⁻¹) :=
+        mul_le_mul' tsub_le_self le_rfl
+      _ ≤ _ := by rw [one_mul]; exact tsub_le_tsub_left hinv _
+  apply ENNReal.le_sub_of_add_le_right (ne_top_of_le_ne_top (by simp) (hsquare.trans tsub_le_self))
+  calc
+    _ ≤ (Fintype.card Digest : ENNReal)⁻¹ + (1 - (Fintype.card Digest : ENNReal)⁻¹) := add_le_add le_rfl hsquare
+    _ = 1 := add_tsub_cancel_of_le hone
+
+theorem prob_stopped_observe {Answer Memory : Type} (response : SPMF Answer)
+    (stopped : Memory) (next : Answer → Memory) :
+    Pr[fun result => result.1 = none |
+      RetainedObservation.observe response (pure (none, stopped)) (fun answer => pure (some answer, next answer))] =
+      response.toPMF none := by
+  rw [RetainedObservation.observe, probEvent_bind_eq_tsum]
+  rw [tsum_option _ ENNReal.summable]
+  simp only [probEvent_pure, if_true, reduceCtorEq, if_false,
+    mul_one, mul_zero, tsum_zero, add_zero, SPMF.probOutput_liftM, PMF.probOutput_eq_apply]
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels) (actions : inputs → Action inputs)
+
+theorem prob_lazyRun_execute_probe_stop (input : inputs) (test : Probe CanonicalCoordinate) (state : State inputs)
+    (hrow : state.rows input = none) :
+    Pr[fun result => result.1 = none |
+      lazyRun (environment parameter inputs words disclosed known actions) (execute (.probe input test)) state] =
+      (lazyResponse state.candidates test).toPMF none := by
+  simp only [lazyRun, execute, runWith, simulateQ_spec_query, lazyImpl, OptionT.run_mk, StateT.run_mk, hrow]
+  exact prob_stopped_observe _ _ _
+
+attribute [local irreducible] lazyResponse probeHazard
+
+theorem prob_hashQuery_stop_le (input : inputs) (state : State inputs) (bound : ENNReal)
+    (hcovered : RowsCovered inputs state) (hlocal : Local input (actions input))
+    (hprobe : ∀ row test, actions input = .probe row test → (lazyResponse state.candidates test).toPMF none ≤ bound) :
+    Pr[fun result => result.1 = none |
+      lazyRun (environment parameter inputs words disclosed known actions) (hashQuery input) state] ≤ bound := by
+  rw [hashQuery, lazyRun_prepare_bind]
+  cases hcache : state.memory.cache input.val with
+  | some answer =>
+      rw [prepare_cached parameter inputs words disclosed known actions input state.memory answer hcache, lazyRun_execute_known]
+      simp only [probEvent_pure, reduceCtorEq, if_false, zero_le]
+  | none =>
+      have hrow := rowsCovered_fresh inputs state hcovered input hcache
+      cases haction : actions input with
+      | known answer =>
+          simp only [prepare, hcache, haction]
+          rw [lazyRun_execute_known]
+          simp only [probEvent_pure, reduceCtorEq, if_false, zero_le]
+      | read row =>
+          simp only [prepare, hcache, haction]
+          rw [lazyRun_execute_read]
+          simp only [probEvent_map, Function.comp_def, reduceCtorEq, probEvent_False, zero_le]
+      | probe row test =>
+          have heq : row = input := by simpa only [haction, Local] using hlocal
+          subst row
+          simp only [prepare, hcache, haction]
+          let paid : State inputs := { state with memory := charge parameter words disclosed known input.val state.memory }
+          have hpaid : paid.candidates = state.candidates := rfl
+          have hstop := prob_lazyRun_execute_probe_stop parameter inputs words disclosed known actions input test paid hrow
+          rw [hpaid] at hstop
+          exact hstop.le.trans (hprobe input test haction)
+
+omit actions in
+theorem prob_prefixHashQuery_stop_le (hencoding : canonicalEncodingInputs parameter ⊆ inputs)
+    (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+    (input : inputs) (state : State inputs) (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : RowsCovered inputs state) (hbound : HiddenCandidateBound words disclosed state) :
+    Pr[fun result => result.1 = none |
+      lazyRun (prefixEnvironment parameter inputs hencoding words disclosed known publicReplies selections rows)
+        (hashQuery input) state] ≤ probeHazard state.memory.probes := by
+  refine prob_hashQuery_stop_le parameter inputs words disclosed known
+    (freshPrefix parameter inputs hencoding words disclosed known publicReplies selections rows) input state
+    (probeHazard state.memory.probes) hcovered
+    (freshPrefix_local parameter inputs hencoding words disclosed known publicReplies selections rows input) ?_
+  intro row test haction
+  have hroute := freshPrefix_probe_route parameter inputs hencoding words disclosed known publicReplies selections rows
+    input row test haction
+  cases test with
+  | output parent =>
+      rw [lazyResponse_output_failure _ ha parent]
+      exact digest_inverse_le_probeHazard _
+  | pair child parent hne candidate =>
+      have hspec := route_spec parameter words disclosed known known (fun _ _ => rfl) input.val
+      rw [hroute] at hspec
+      obtain ⟨_, _, _, _, hhidden, _⟩ := hspec
+      have hmin : 2 ^ digestBits - state.memory.probes ≤ (state.candidates child).card := by
+        have h := hbound child hhidden
+        omega
+      unfold probeHazard
+      exact lazyResponse_pair_failure_le_rounds state.candidates ha child parent hne candidate state.memory.probes hmin
+
+end SphincsSecurity.Concrete.ResidualByteFrontend
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualByteRun.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualByteRun.lean
new file mode 100644
index 000000000..e209b85fa
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualByteRun.lean
@@ -0,0 +1,45 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.ResidualByteCorrespondence
+namespace SphincsSecurity.Concrete.ResidualByteFrontend
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting HiddenLabelObservation ResidualByteAction
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs
+set_option backward.isDefEq.respectTransparency false
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels) (actions : inputs → Action inputs)
+
+noncomputable def translate (inputs : Finset HashInput) : QueryImpl OracleWorld (OracleComp (World inputs))
+  | .inl input => liftM ((World inputs).query (.inl (.random input)))
+  | .inr input => if hin : input ∈ inputs then hashQuery ⟨input, hin⟩ else pure (0 : HashOutput)
+
+noncomputable def byteRun {Result : Type} (actual : Labels) (seed : inputs → HashOutput)
+    (computation : OracleComp OracleWorld Result) (state : State inputs) : SPMF (Option Result × State inputs) :=
+  AdaptiveResidualLabels.observedRun (environment parameter inputs words disclosed known actions)
+    actual seed (simulateQ (translate inputs) computation) state
+
+theorem observedRun_bind {A B : Type} (actual : Labels) (seed : inputs → HashOutput)
+    (computation : OracleComp (World inputs) A) (next : A → OracleComp (World inputs) B) (state : State inputs) :
+    AdaptiveResidualLabels.observedRun (environment parameter inputs words disclosed known actions)
+      actual seed (computation >>= next) state =
+        (AdaptiveResidualLabels.observedRun (environment parameter inputs words disclosed known actions)
+          actual seed computation state >>= fun result =>
+            result.1.elim (pure (none, result.2)) (fun answer =>
+              AdaptiveResidualLabels.observedRun (environment parameter inputs words disclosed known actions)
+                actual seed (next answer) result.2)) := by
+  simp only [AdaptiveResidualLabels.observedRun, AdaptiveResidualLabels.runWith, simulateQ_bind,
+    OptionT.run_bind, Option.elimM, StateT.run_bind]
+  apply congrArg (fun continuation =>
+    (simulateQ (AdaptiveResidualLabels.observedImpl
+      (environment parameter inputs words disclosed known actions) actual seed) computation).run.run state >>= continuation)
+  funext result
+  rcases result with ⟨answer, state⟩
+  cases answer <;> rfl
+
+theorem byteRun_pure {Result : Type} (actual : Labels) (seed : inputs → HashOutput) (value : Result) (state : State inputs) :
+    byteRun parameter inputs words disclosed known actions actual seed (pure value) state =
+      pure (some value, state) := by
+  simp only [byteRun, simulateQ_pure, AdaptiveResidualLabels.observedRun, AdaptiveResidualLabels.runWith_pure]
+
+end SphincsSecurity.Concrete.ResidualByteFrontend
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualGraphGame.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualGraphGame.lean
new file mode 100644
index 000000000..70ea70a13
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualGraphGame.lean
@@ -0,0 +1,49 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.CanonicalGraphGame
+import SphincsSecurity.Proof.Residual.CanonicalResidualQuery
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec OracleComp.DeferredSampling
+set_option backward.isDefEq.respectTransparency false
+attribute [local irreducible] canonicalGraphInputs canonicalPayloadInputs canonicalGraphOrder instFintypePosition
+
+noncomputable local instance residualGameLabelsSampleable : SampleableType CanonicalGraphLabels :=
+  SampleableType.ofFintype CanonicalGraphLabels
+
+noncomputable def residualGraphOracleGame (inputs : Finset HashInput) (dummy : OtsReferenceWords) (adversary : Adversary) :
+    ProbComp (Bool × SigningBoundaryTrace) := do
+  let parameter ← sampleParameter
+  let otsSecret ← sampleOtsSecrets
+  let ftsSecret ← sampleFtsSecrets
+  let labels ← ($ᵗ CanonicalGraphLabels : ProbComp _)
+  let residual ← sampleHashTable inputs
+  graphFrontierGameRest parameter otsSecret ftsSecret labels
+    (programmedHash parameter otsSecret ftsSecret labels (finiteHashAnswer ∅ inputs residual)) dummy adversary
+
+theorem evalDist_canonicalGraph_eq_residualGraph (inputs : Finset HashInput)
+    (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary) :
+    𝒟[canonicalGraphOracleGame inputs hgraph dummy adversary] =
+      𝒟[residualGraphOracleGame inputs dummy adversary] := by
+  rw [canonicalGraphOracleGame, residualGraphOracleGame]
+  apply evalDist_bind_congr_left
+  intro parameter
+  apply evalDist_bind_congr_left
+  intro otsSecret
+  apply evalDist_bind_congr_left
+  intro ftsSecret
+  have h := evalDist_plantCanonicalGraph_bind_eq_residual parameter otsSecret ftsSecret inputs (hgraph parameter)
+    (fun labels table => graphFrontierGameRest parameter otsSecret ftsSecret labels
+      (finiteHashAnswer ∅ inputs table) dummy adversary)
+  simpa only [finiteHashAnswer_program_eq] using h
+
+theorem evalDist_boundaryGameCore_residualGraph (inputs : Finset HashInput)
+    (hgraph : ∀ parameter, canonicalGraphInputs parameter ⊆ inputs)
+    (dummy : OtsReferenceWords) (adversary : Adversary)
+    (hinputs : hashInputs (boundaryGameCore adversary) ⊆ inputs) :
+    𝒟[(simulateQ romImpl (boundaryGameCore adversary)).run' ∅] =
+      𝒟[residualGraphOracleGame inputs dummy adversary] :=
+  (evalDist_boundaryGameCore_canonicalGraph inputs hgraph dummy adversary hinputs).trans
+    (evalDist_canonicalGraph_eq_residualGraph inputs hgraph dummy adversary)
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualProbeCompletion.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualProbeCompletion.lean
new file mode 100644
index 000000000..57645f4e3
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualProbeCompletion.lean
@@ -0,0 +1,57 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.ResidualTableCompletion
+namespace SphincsSecurity.Concrete.ResidualProbeCompletion
+
+open _root_.OracleComp OracleSpec HiddenLabelObservation UniformTableCompletion RetainedObservation ResidualTableCompletion
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+variable {Coordinate Cell Result : Type} [Fintype Coordinate] [DecidableEq Coordinate]
+  [Fintype Cell] [DecidableEq Cell]
+
+omit [Fintype Coordinate] [DecidableEq Coordinate] [Fintype Cell] [DecidableEq Cell] in
+theorem observe_response (labels : Coordinate → Digest) (probe : Probe Coordinate)
+    (stopped : SPMF Result) (next : HashOutput → SPMF Result) :
+    observe (response labels probe) stopped next =
+      ((liftM (PMF.uniformOfFintype HashOutput) : SPMF _) >>= fun answer =>
+        if probe.keep labels answer then next answer else stopped) := by
+  rw [observe, response, toPMF_bind_lift]
+  simp only [← PMF.monad_bind_eq_bind, evalDist_bind, bind_assoc]
+  apply congrArg ((liftM (PMF.uniformOfFintype HashOutput) : SPMF _) >>= ·)
+  funext answer
+  by_cases h : probe.keep labels answer
+  · simp only [h, if_true, SPMF.toPMF_pure, SPMF.lift_pure, pure_bind]
+  · simp only [h, if_false, SPMF.toPMF_failure, SPMF.lift_pure, pure_bind]
+
+omit [Fintype Coordinate] [DecidableEq Coordinate] in
+theorem fixedLabels_fresh (labels : Coordinate → Digest) (cache : Cache Cell) (input : Cell)
+    (hfresh : cache input = none) (probe : Probe Coordinate) (stopped : SPMF Result)
+    (next : HashOutput → (Cell → HashOutput) → SPMF Result) :
+    (completeRows cache >>= fun table =>
+      if probe.keep labels (table input) then next (table input) table else stopped) =
+        observe (response labels probe) stopped
+          (fun answer => completeRows (Function.update cache input (some answer)) >>= next answer) := by
+  rw [bind_fresh cache input hfresh (fun answer table => if probe.keep labels answer then next answer table else stopped),
+    observe_response]
+  apply congrArg ((liftM (PMF.uniformOfFintype HashOutput) : SPMF _) >>= ·)
+  funext answer
+  by_cases h : probe.keep labels answer
+  · simp only [h, if_true]
+  · simp only [h, if_false, completeRows_bind_const]
+
+theorem bind_fresh_probe (candidates : Coordinate → Finset Digest)
+    (ha : ∀ coordinate, (candidates coordinate).Nonempty) (cache : Cache Cell) (input : Cell)
+    (hfresh : cache input = none) (probe : Probe Coordinate) (stopped : SPMF Result)
+    (next : HashOutput → (Coordinate → Digest) → (Cell → HashOutput) → SPMF Result) :
+    (complete candidates >>= fun labels => completeRows cache >>= fun table =>
+      if probe.keep labels (table input) then next (table input) labels table else stopped) =
+        observe (lazyResponse candidates probe) stopped (fun answer =>
+          complete (probe.restrict candidates answer) >>= fun labels =>
+            completeRows (Function.update cache input (some answer)) >>= next answer labels) := by
+  have hfixed (labels : Coordinate → Digest) := fixedLabels_fresh labels cache input hfresh probe stopped
+    (fun answer table => next answer labels table)
+  simp_rw [hfixed]
+  exact bind_response_stopped candidates ha probe stopped
+    (fun answer labels => completeRows (Function.update cache input (some answer)) >>= next answer labels)
+
+end SphincsSecurity.Concrete.ResidualProbeCompletion
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualSigningDisclosure.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualSigningDisclosure.lean
new file mode 100644
index 000000000..5ad2653a1
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualSigningDisclosure.lean
@@ -0,0 +1,121 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Reference.CausalPublicSigning
+namespace SphincsSecurity.Concrete.ResidualByteFrontend
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+set_option backward.isDefEq.respectTransparency false
+
+variable {inputs : Finset HashInput}
+
+open AdaptiveResidualLabels hiding World State Environment
+
+def jointDisclosure (coordinate : CanonicalCoordinate) : OracleComp (World inputs) Digest :=
+  liftM ((World inputs).query (.inr (.disclose coordinate)))
+
+def jointDisclosureSequenceState (environment : AdaptiveResidualLabels.Environment (ControlSpec inputs) CanonicalCoordinate inputs ExternalMemory)
+    (labels : CanonicalCoordinate → Digest) {n : Nat} (coordinates : Fin n → CanonicalCoordinate)
+    (state : State inputs) : State inputs :=
+  (List.ofFn coordinates).foldl (fun state coordinate => disclosedState environment state coordinate (labels coordinate)) state
+
+theorem observedRun_jointDisclosureSequence_bind {Result : Type}
+    (environment : AdaptiveResidualLabels.Environment (ControlSpec inputs) CanonicalCoordinate inputs ExternalMemory) (labels : CanonicalCoordinate → Digest) (seed : inputs → HashOutput)
+    {n : Nat} (coordinates : Fin n → CanonicalCoordinate)
+    (next : (Fin n → Digest) → OracleComp (World inputs) Result)
+    (state : State inputs) :
+    observedRun environment labels seed ((sequenceFin fun index => jointDisclosure (coordinates index)) >>= next) state =
+      observedRun environment labels seed (next (fun index => labels (coordinates index)))
+        (jointDisclosureSequenceState environment labels coordinates state) := by
+  induction n generalizing state with
+  | zero =>
+      have hvalues : (Fin.elim0 : Fin 0 → Digest) = (fun index => labels (coordinates index)) := by
+        funext index
+        exact Fin.elim0 index
+      simp only [sequenceFin, pure_bind, hvalues, jointDisclosureSequenceState, List.ofFn_zero, List.foldl_nil]
+  | succ n ih =>
+      rw [sequenceFin, bind_assoc]
+      change runWith (observedImpl environment labels seed)
+        (liftM ((World inputs).query (.inr (.disclose (coordinates 0)))) >>= _) state = _
+      rw [runWith_query_bind]
+      simp only [observedImpl, OptionT.run_mk, StateT.run_mk, pure_bind, bind_assoc]
+      change observedRun environment labels seed
+        ((sequenceFin fun index => jointDisclosure (coordinates index.succ)) >>=
+          fun tail => next (Fin.cons (labels (coordinates 0)) tail))
+        (disclosedState environment state (coordinates 0) (labels (coordinates 0))) = _
+      rw [ih]
+      have hvalues : Fin.cons (labels (coordinates 0)) (fun index => labels (coordinates index.succ)) =
+          (fun index => labels (coordinates index)) := by
+        funext index
+        cases index using Fin.cases <;> rfl
+      rw [hvalues]
+      simp only [jointDisclosureSequenceState, List.ofFn_succ, List.foldl_cons]
+
+def jointCompleteSigningRecord (record : PublicSigningRecord) :
+    OracleComp (World inputs) ((Option Signature × Option FewTimeView) × SigningBoundaryTrace) :=
+  match record.1.1, record.1.2 with
+  | some plan, some view => do
+      let secrets ← sequenceFin fun tree => jointDisclosure (.ftsStart view.1 tree (view.2 tree))
+      pure ((some (plan.finish secrets), some view), record.2)
+  | _, _ => pure ((none, record.1.2), record.2)
+
+def jointCompletedSigningState (environment : AdaptiveResidualLabels.Environment (ControlSpec inputs) CanonicalCoordinate inputs ExternalMemory)
+    (labels : CanonicalCoordinate → Digest) (record : PublicSigningRecord)
+    (state : State inputs) : State inputs :=
+  match record.1.1, record.1.2 with
+  | some _, some view => jointDisclosureSequenceState environment labels (fun tree => .ftsStart view.1 tree (view.2 tree)) state
+  | _, _ => state
+
+theorem observedRun_jointCompleteSigningRecord
+    (environment : AdaptiveResidualLabels.Environment (ControlSpec inputs) CanonicalCoordinate inputs ExternalMemory) (labels : CanonicalCoordinate → Digest) (seed : inputs → HashOutput)
+    (record : PublicSigningRecord) (state : State inputs) :
+    observedRun environment labels seed (jointCompleteSigningRecord record) state =
+      pure (some (completePublicSigningRecord (fun index tree leaf => labels (.ftsStart index tree leaf)) record),
+        jointCompletedSigningState environment labels record state) := by
+  obtain ⟨⟨plan, view⟩, trace⟩ := record
+  cases plan <;> cases view <;> simp only [jointCompleteSigningRecord, completePublicSigningRecord, jointCompletedSigningState,
+    Option.map_none, Option.map_some]
+  all_goals first
+    | exact runWith_pure (observedImpl environment labels seed) _ _
+    | rw [observedRun_jointDisclosureSequence_bind]; exact runWith_pure (observedImpl environment labels seed) _ _
+
+variable (parameter : PublicParameter) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels)
+    (actions : inputs → ResidualByteAction.Action inputs)
+
+theorem jointDisclosureSequenceState_memory (actual : Labels) {n : Nat} (coordinates : Fin n → CanonicalCoordinate)
+    (state : State inputs) :
+    (jointDisclosureSequenceState (environment parameter inputs words disclosed known actions) actual coordinates state).memory = state.memory := by
+  induction n generalizing state with
+  | zero => rfl
+  | succ n ih =>
+      rw [jointDisclosureSequenceState, List.ofFn_succ, List.foldl_cons]
+      change (jointDisclosureSequenceState (environment parameter inputs words disclosed known actions) actual
+        (fun index => coordinates index.succ)
+        (disclosedState (environment parameter inputs words disclosed known actions) state (coordinates 0) (actual (coordinates 0)))).memory = _
+      rw [ih]
+      rfl
+
+theorem observedRun_account_bind {Result : Type} (actual : Labels) (seed : inputs → HashOutput) (cost : Nat)
+    (next : Unit → OracleComp (World inputs) Result) (state : State inputs) :
+    observedRun (environment parameter inputs words disclosed known actions) actual seed
+      (liftM ((World inputs).query (.inl (.account cost))) >>= next) state =
+    observedRun (environment parameter inputs words disclosed known actions) actual seed
+      (next ()) { state with memory := accountWork state.memory cost } := by
+  rw [observedRun, runWith_query_bind]
+  simp only [observedImpl, environment, OptionT.run_mk, StateT.run_mk,
+    SPMF.lift_pure, pure_bind, Option.elim_some, observedRun, accountWork]
+
+omit parameter words disclosed known actions in
+def jointCompleteSigningWork (work : PublicSigningRecord × Nat) :
+    OracleComp (World inputs) ((Option Signature × Option FewTimeView) × SigningBoundaryTrace) := do
+  let _ ← liftM ((World inputs).query (.inl (.account work.2)))
+  jointCompleteSigningRecord work.1
+
+theorem observedRun_jointCompleteSigningWork (actual : Labels) (seed : inputs → HashOutput)
+    (work : PublicSigningRecord × Nat) (state : State inputs) :
+    observedRun (environment parameter inputs words disclosed known actions) actual seed (jointCompleteSigningWork work) state =
+      pure (some (completePublicSigningRecord (fun index tree leaf => actual (.ftsStart index tree leaf)) work.1),
+        jointCompletedSigningState (environment parameter inputs words disclosed known actions) actual work.1
+          { state with memory := accountWork state.memory work.2 }) := by
+  rw [jointCompleteSigningWork, observedRun_account_bind, observedRun_jointCompleteSigningRecord]
+
+end SphincsSecurity.Concrete.ResidualByteFrontend
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualSigningProgram.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualSigningProgram.lean
new file mode 100644
index 000000000..3cd603aa0
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualSigningProgram.lean
@@ -0,0 +1,18 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Ots.ReferencePrefixSigning
+import SphincsSecurity.Proof.Residual.ResidualSigningDisclosure
+namespace SphincsSecurity.Concrete.ResidualByteFrontend
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting ResidualByteAction
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def jointSigningProgram (inputs : Finset HashInput) (parameter : PublicParameter) (root : Digest)
+    (known : Labels) (words : OtsReferenceWords) (selections : ReferenceFamily) (message : Message) :
+    OracleComp (World inputs) ((Option Signature × Option FewTimeView) × SigningBoundaryTrace) := do
+  let work ← simulateQ (checkedTranslate inputs (PublicEncodingMatch.Match parameter (knownEncodingMessage known) words selections))
+    (publicSigningWork parameter root known words selections message)
+  jointCompleteSigningWork work
+
+end SphincsSecurity.Concrete.ResidualByteFrontend
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualTableCompletion.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualTableCompletion.lean
new file mode 100644
index 000000000..1c0d8af8b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/ResidualTableCompletion.lean
@@ -0,0 +1,77 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedObservation
+namespace SphincsSecurity.Concrete.ResidualTableCompletion
+
+open _root_.OracleComp ENNReal UniformTableCompletion
+set_option backward.isDefEq.respectTransparency false
+
+variable {Cell : Type} [Fintype Cell] [DecidableEq Cell]
+
+abbrev Cache (Cell : Type) := Cell → Option HashOutput
+
+def allowed (cache : Cache Cell) : Cell → Finset HashOutput :=
+  fun input => match cache input with
+    | none => Finset.univ
+    | some answer => {answer}
+
+omit [Fintype Cell] [DecidableEq Cell] in
+theorem allowed_nonempty (cache : Cache Cell) : ∀ input, (allowed cache input).Nonempty := by
+  intro input
+  cases h : cache input <;> simp only [allowed, h]
+  · exact Finset.univ_nonempty
+  · exact Finset.singleton_nonempty _
+
+noncomputable def completeRows (cache : Cache Cell) : SPMF (Cell → HashOutput) :=
+  complete (allowed cache)
+
+noncomputable def reply (cache : Cache Cell) (input : Cell) : SPMF HashOutput :=
+  match cache input with
+  | none => liftM (PMF.uniformOfFintype HashOutput)
+  | some answer => pure answer
+
+theorem completeRows_empty :
+    completeRows (Cell := Cell) (fun _ => none) = liftM (PMF.uniformOfFintype (Cell → HashOutput)) := by
+  apply SPMF.ext
+  intro table
+  simp only [completeRows, complete_apply, allowed, Finset.mem_univ, implies_true, if_true,
+    Finset.card_univ, Finset.prod_const, Finset.card_univ, SPMF.liftM_apply, PMF.uniformOfFintype_apply, Fintype.card_fun]
+
+omit [Fintype Cell] [DecidableEq Cell] in
+theorem cell_eq_reply (cache : Cache Cell) (input : Cell) : cell (allowed cache input) = reply cache input := by
+  apply SPMF.ext
+  intro answer
+  cases h : cache input with
+  | none => simp only [cell_apply, allowed, h, Finset.mem_univ, if_true, Finset.card_univ,
+      reply, SPMF.liftM_apply, PMF.uniformOfFintype_apply]
+  | some value => simp only [cell_apply, allowed, h, Finset.mem_singleton, Finset.card_singleton,
+      Nat.cast_one, inv_one, reply, SPMF.pure_apply]
+
+omit [Fintype Cell] in
+theorem allowed_update (cache : Cache Cell) (input : Cell) (answer : HashOutput) :
+    discloseTableValue (allowed cache) input answer = allowed (Function.update cache input (some answer)) := by
+  funext other
+  by_cases h : other = input
+  · subst other
+    simp only [discloseTableValue, Function.update_self, allowed]
+  · simp only [discloseTableValue, Function.update_of_ne h, allowed]
+
+theorem bind_read {Result : Type} (cache : Cache Cell) (input : Cell)
+    (next : HashOutput → (Cell → HashOutput) → SPMF Result) :
+    (completeRows cache >>= fun table => next (table input) table) =
+      (reply cache input >>= fun answer => completeRows (Function.update cache input (some answer)) >>= next answer) := by
+  rw [completeRows, bind_disclose, cell_eq_reply]
+  simp only [allowed_update, completeRows]
+
+theorem bind_fresh {Result : Type} (cache : Cache Cell) (input : Cell) (hfresh : cache input = none)
+    (next : HashOutput → (Cell → HashOutput) → SPMF Result) :
+    (completeRows cache >>= fun table => next (table input) table) =
+      ((liftM (PMF.uniformOfFintype HashOutput) : SPMF _) >>= fun answer =>
+        completeRows (Function.update cache input (some answer)) >>= next answer) := by
+  rw [bind_read, reply, hfresh]
+
+theorem completeRows_bind_const {Result : Type} (cache : Cache Cell) (next : SPMF Result) :
+    (completeRows cache >>= fun _ => next) = next := by
+  rw [completeRows, complete_of_nonempty _ (allowed_nonempty cache)]
+  exact RetainedObservation.lift_bind_const _ _
+
+end SphincsSecurity.Concrete.ResidualTableCompletion
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedObservation.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedObservation.lean
new file mode 100644
index 000000000..4112b6a50
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedObservation.lean
@@ -0,0 +1,143 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.HiddenLabelObservation
+namespace SphincsSecurity.Concrete.RetainedObservation
+
+open _root_.OracleComp ENNReal
+set_option backward.isDefEq.respectTransparency false
+
+variable {Label Answer Result : Type}
+
+theorem bind_comm (p : SPMF Label) (q : SPMF Answer) (next : Label → Answer → SPMF Result) :
+    (p >>= fun label => q >>= next label) = (q >>= fun answer => p >>= fun label => next label answer) := by
+  apply SPMF.ext
+  intro result
+  simp only [SPMF.bind_apply_eq_tsum, ← ENNReal.tsum_mul_left]
+  rw [ENNReal.tsum_comm]
+  apply tsum_congr
+  intro answer
+  apply tsum_congr
+  intro label
+  exact mul_left_comm _ _ _
+
+theorem bind_congr (p : SPMF Label) (f g : Label → SPMF Result)
+    (h : ∀ label, p label ≠ 0 → f label = g label) : (p >>= f) = (p >>= g) := by
+  apply SPMF.ext
+  intro result
+  simp only [SPMF.bind_apply_eq_tsum]
+  apply tsum_congr
+  intro label
+  by_cases hp : p label = 0
+  · simp only [hp, zero_mul]
+  · rw [h label hp]
+
+theorem bind_nonzero (p : SPMF Label) (next : Label → SPMF Result) (result : Result) :
+    (p >>= next) result ≠ 0 ↔ ∃ label, p label ≠ 0 ∧ next label result ≠ 0 := by
+  rw [← SPMF.mem_support_iff, SPMF.support_bind]
+  simp only [Set.mem_iUnion, SPMF.mem_support_iff, exists_prop]
+
+theorem lift_bind_const (p : PMF Label) (next : SPMF Result) :
+    ((liftM p : SPMF Label) >>= fun _ => next) = next := by
+  apply SPMF.ext
+  intro result
+  simp only [SPMF.bind_apply_eq_tsum, SPMF.liftM_apply, ENNReal.tsum_mul_right, PMF.tsum_coe, one_mul]
+
+theorem toPMF_bind_lift (p : PMF Label) (next : Label → SPMF Answer) :
+    ((liftM p : SPMF Label) >>= next).toPMF = p.bind (fun label => (next label).toPMF) := by
+  rw [SPMF.toPMF_bind, SPMF.liftM_eq_map, SPMF.toPMF_mk]
+  simp only [Option.elimM, PMF.monad_bind_eq_bind, PMF.bind_map]
+  rfl
+
+noncomputable def observe (response : SPMF Answer) (stopped : SPMF Result)
+    (next : Answer → SPMF Result) : SPMF Result :=
+  (liftM response.toPMF : SPMF (Option Answer)) >>= fun
+    | none => stopped
+    | some answer => next answer
+
+theorem observe_apply (response : SPMF Answer) (stopped : SPMF Result)
+    (next : Answer → SPMF Result) (result : Result) :
+    observe response stopped next result = response.toPMF none * stopped result +
+      ∑' answer, response answer * next answer result := by
+  rw [observe, SPMF.bind_apply_eq_tsum]
+  simp only [SPMF.liftM_apply]
+  rw [tsum_option _ ENNReal.summable]
+  rfl
+
+theorem observe_nonzero (response : SPMF Answer) (stopped : SPMF Result)
+    (next : Answer → SPMF Result) (result : Result) :
+    observe response stopped next result ≠ 0 ↔
+      (response.toPMF none ≠ 0 ∧ stopped result ≠ 0) ∨
+        ∃ answer, response answer ≠ 0 ∧ next answer result ≠ 0 := by
+  rw [observe, bind_nonzero]
+  constructor
+  · rintro ⟨answer, hanswer, hresult⟩
+    cases answer with
+    | none => exact Or.inl ⟨by simpa only [SPMF.liftM_apply] using hanswer, hresult⟩
+    | some answer =>
+        refine Or.inr ⟨answer, ?_, hresult⟩
+        rw [SPMF.apply_eq_toPMF_some response answer]
+        simpa only [SPMF.liftM_apply] using hanswer
+  · rintro (⟨hanswer, hresult⟩ | ⟨answer, hanswer, hresult⟩)
+    · exact ⟨none, by simpa only [SPMF.liftM_apply] using hanswer, hresult⟩
+    · refine ⟨some answer, ?_, hresult⟩
+      rw [SPMF.liftM_apply, ← SPMF.apply_eq_toPMF_some response answer]
+      exact hanswer
+
+theorem observe_bind {Other : Type} (response : SPMF Answer) (stopped : SPMF Result)
+    (next : Answer → SPMF Result) (after : Result → SPMF Other) :
+    (observe response stopped next >>= after) =
+      observe response (stopped >>= after) (fun answer => next answer >>= after) := by
+  simp only [observe, bind_assoc]
+  congr 1
+  funext answer
+  cases answer <;> rfl
+
+theorem observe_congr (response : SPMF Answer) (stopped : SPMF Result)
+    (f g : Answer → SPMF Result) (h : ∀ answer, response answer ≠ 0 → f answer = g answer) :
+    observe response stopped f = observe response stopped g := by
+  apply SPMF.ext
+  intro result
+  simp only [observe_apply]
+  apply congrArg (response.toPMF none * stopped result + ·)
+  apply tsum_congr
+  intro answer
+  by_cases hp : response answer = 0
+  · simp only [hp, zero_mul]
+  · rw [h answer hp]
+
+theorem posterior_observe (prior : PMF Label) (response : Label → SPMF Answer)
+    (predictive : SPMF Answer) (posterior : Answer → SPMF Label)
+    (hpredictive : predictive = ((liftM prior : SPMF Label) >>= response))
+    (hmass : ∀ answer label, predictive answer * posterior answer label = prior label * response label answer)
+    (stopped : SPMF Result) (next : Answer → Label → SPMF Result) :
+    ((liftM prior : SPMF Label) >>= fun label => observe (response label) stopped (fun answer => next answer label)) =
+      observe predictive stopped (fun answer => posterior answer >>= next answer) := by
+  have hnone : (∑' label, prior label * (response label).toPMF none) = predictive.toPMF none := by
+    rw [hpredictive, toPMF_bind_lift, PMF.bind_apply]
+  apply SPMF.ext
+  intro result
+  simp only [SPMF.bind_apply_eq_tsum, SPMF.liftM_apply, observe_apply, mul_add, ENNReal.tsum_add]
+  apply congrArg₂ (· + ·)
+  · simpa only [← mul_assoc, ENNReal.tsum_mul_right] using congrArg (· * stopped result) hnone
+  · simp only [← ENNReal.tsum_mul_left, ← mul_assoc, hmass]
+    rw [ENNReal.tsum_comm]
+
+end SphincsSecurity.Concrete.RetainedObservation
+
+namespace SphincsSecurity.Concrete.HiddenLabelObservation
+
+open _root_.OracleComp UniformTableCompletion RetainedObservation
+
+theorem bind_response_stopped {Coordinate Result : Type} [Fintype Coordinate] [DecidableEq Coordinate]
+    (allowed : Coordinate → Finset Digest) (ha : ∀ coordinate, (allowed coordinate).Nonempty)
+    (probe : Probe Coordinate) (stopped : SPMF Result) (next : HashOutput → (Coordinate → Digest) → SPMF Result) :
+    (complete allowed >>= fun labels => observe (response labels probe) stopped (fun answer => next answer labels)) =
+      observe (lazyResponse allowed probe) stopped (fun answer => complete (probe.restrict allowed answer) >>= next answer) := by
+  have h := posterior_observe (uniformTable allowed ha) (fun labels => response labels probe)
+    (lazyResponse allowed probe) (fun answer => complete (probe.restrict allowed answer))
+    (by rw [lazyResponse, complete_of_nonempty allowed ha])
+    (fun answer labels => by
+      simpa only [complete_of_nonempty allowed ha, SPMF.liftM_apply] using posterior_mass allowed probe answer labels)
+    stopped next
+  simpa only [complete_of_nonempty allowed ha] using h
+
+end SphincsSecurity.Concrete.HiddenLabelObservation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualAccounting.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualAccounting.lean
new file mode 100644
index 000000000..c433a7416
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualAccounting.lean
@@ -0,0 +1,164 @@
+import SphincsSecurity.Proof.Residual.RetainedResidualBankCompleteness
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs sourceInputs
+  signDigestLoop signAfterDigest
+set_option backward.isDefEq.respectTransparency false
+
+def MonitoredAccounting {inputs : Finset HashInput} (state : MonitoredState inputs) : Prop :=
+  state.2.stopped = false → state.2.spent = state.1.memory.external.hashCalls
+
+private theorem update_spent_eq {inputs : Finset HashInput} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule) (input : (OracleWorld + SigningSpec).Domain)
+    (state : MonitoredState inputs) (hbefore : MonitoredAccounting state) (length : Nat)
+    (record : ProposalExecutionRecord input) (after : Memory)
+    (hhash : after.external.hashCalls = state.1.memory.external.hashCalls + record.trace.hashCalls)
+    (halive : (certificateMonitorUpdate key budget required stopAfter input (monitorView state) length record).stopped = false) :
+    (certificateMonitorUpdate key budget required stopAfter input (monitorView state) length record).spent = after.external.hashCalls := by
+  by_cases hactive : CertificateMonitorActive key budget input (monitorView state)
+  · rw [certificateMonitorUpdate, if_pos hactive]
+    change state.2.spent + record.trace.hashCalls = after.external.hashCalls
+    rw [hbefore hactive.1, hhash]
+  · rw [certificateMonitorUpdate_inactive _ _ _ _ _ _ _ _ hactive] at halive
+    cases halive
+
+variable (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+  (words : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+  (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+theorem monitoredStep_accounting (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState inputs)
+    (hvalid : MonitoredValid inputs state) (hinputs : requestInputs key input ⊆ inputs)
+    (hbefore : MonitoredAccounting state)
+    (result : Option ((OracleWorld + SigningSpec).Range input) × MonitoredState inputs)
+    (hresult : monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state result ≠ 0) :
+    MonitoredAccounting result.2 ∧
+      state.1.memory.external.hashCalls + signingMacroHashCost input ≤ result.2.1.memory.external.hashCalls ∧
+      result.2.1.memory.log.length = state.1.memory.log.length + if input.isRight then 1 else 0 := by
+  cases input with
+  | inl input =>
+      rw [monitoredStep, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨raw, hraw, hresult⟩ := hresult
+      simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      have hlog := lazyRun_externalProgram_log key inputs hencoding words publicReplies selections rows _ state.1 hvalid.1 raw hraw
+      rw [lazyRun_externalProgram] at hraw
+      have hhash := lazyByteRun_world_hashCalls key.parameter inputs hencoding words publicReplies selections rows state.1.memory.routing
+        input hinputs state.1 hvalid.1 raw hraw
+      have hcost : state.1.memory.external.hashCalls + signingMacroHashCost (.inl input) ≤ raw.2.memory.external.hashCalls := by
+        rw [hhash]
+        cases input <;> exact le_refl _
+      refine ⟨?_, hcost, ?_⟩
+      · cases hr : raw.1 with
+        | none => intro halive; simp only [monitoredWorldResult, hr, Option.elim_none] at halive; cases halive
+        | some answer =>
+            intro halive
+            simp only [monitoredWorldResult, hr, Option.elim_some] at halive ⊢
+            apply update_spent_eq key budget required stopAfter (.inl input) state hbefore 0
+              (proposalOfWorldResult key.parameter input (answer, raw.2.memory.external.cache)) raw.2.memory ?_ halive
+            change raw.2.memory.external.hashCalls = state.1.memory.external.hashCalls + (signingBoundaryTrace key.parameter input answer).hashCalls
+            rw [signingBoundaryTrace_hashCalls_eq]
+            cases input <;> exact hhash
+      · change raw.2.memory.log.length = state.1.memory.log.length + 0
+        rw [hlog, Nat.add_zero]
+  | inr message =>
+      rw [monitoredStep, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨annotation, _, hresult⟩ := hresult
+      rw [map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨raw, hraw, hresult⟩ := hresult
+      simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      have hin := digestInputs_of_request key inputs words selections message state.1.memory.routing.known hinputs
+      obtain ⟨record, hr, hm⟩ := lazyRun_jointSigningProgram_memory_trace key.parameter inputs hencoding words publicReplies selections rows
+        state.1.memory.routing key.root message (by simpa only [publicDigestLoop_eq] using hin) state.1 hvalid.1 hvalid.2 raw hraw
+      obtain ⟨other, ho, hmin⟩ := lazyRun_jointSigningProgram_hashCalls_min key inputs hencoding words publicReplies selections rows
+        state.1.memory.routing message hin state.1 hvalid.1 hvalid.2 raw hraw
+      have heq : other = record := Option.some.inj (ho.symm.trans hr)
+      subst other
+      have heq : raw = (some record, raw.2) := Prod.ext hr rfl
+      rw [heq]
+      simp only [monitoredSigningResult]
+      refine ⟨?_, ?_, ?_⟩
+      · intro halive
+        apply update_spent_eq key budget required stopAfter (.inr message) state hbefore annotation.1
+          (proposalOfSigningRecord message record raw.2.memory.external.cache (record.1.2.elim annotation.2 Prod.fst))
+          (raw.2.memory.recordSigning message record) ?_ halive
+        rw [hm]; rfl
+      · change state.1.memory.external.hashCalls + 1024 ≤ raw.2.memory.external.hashCalls
+        rw [hm]
+        change state.1.memory.external.hashCalls + 1024 ≤ state.1.memory.external.hashCalls + record.2.hashCalls
+        omega
+      · rw [hm]
+        simp only [Memory.recordSigning, Memory.applyBoundary, List.length_append, List.length_singleton, Sum.isRight, if_true]
+
+theorem monitoredRun_accounting {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : MonitoredState inputs) (hvalid : MonitoredValid inputs state)
+    (hinputs : sourceInputs key computation ⊆ inputs) (hbefore : MonitoredAccounting state)
+    (result : Option Result × MonitoredState inputs)
+    (hresult : monitoredRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state result ≠ 0) :
+    MonitoredAccounting result.2 ∧ state.1.memory.external.hashCalls ≤ result.2.1.memory.external.hashCalls ∧
+      state.1.memory.log.length ≤ result.2.1.memory.log.length := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value =>
+      rw [monitoredRun_pure] at hresult
+      simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact ⟨hbefore, le_refl _, le_refl _⟩
+  | query_bind input next ih =>
+      rw [monitoredRun_query_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨⟨answer, after⟩, hstep, hresult⟩ := hresult
+      obtain ⟨haccount, hcost, hlog⟩ := monitoredStep_accounting key inputs hencoding words publicReplies selections rows budget required stopAfter
+        input state hvalid ((requestInputs_subset key input next).trans hinputs) hbefore (answer, after) hstep
+      have hcost' : state.1.memory.external.hashCalls ≤ after.1.memory.external.hashCalls := (Nat.le_add_right _ _).trans hcost
+      have hlog' : state.1.memory.log.length ≤ after.1.memory.log.length := by rw [hlog]; exact Nat.le_add_right _ _
+      cases answer with
+      | none =>
+          simp only [Option.elim_none, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          subst result
+          exact ⟨haccount, hcost', hlog'⟩
+      | some answer =>
+          obtain ⟨haccount', hcost'', hlog''⟩ := ih answer after
+            (monitoredStep_valid key inputs hencoding words publicReplies selections rows budget required stopAfter input state hvalid (some answer, after) hstep)
+            ((sourceInputs_next_subset key input next answer).trans hinputs) haccount hresult
+          exact ⟨haccount', hcost'.trans hcost'', hlog'.trans hlog''⟩
+
+theorem monitoredRun_query_conditions {Result : Type} (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Result)
+    (state : MonitoredState inputs) (hvalid : MonitoredValid inputs state)
+    (hinputs : sourceInputs key (OracleSpec.query input >>= next) ⊆ inputs)
+    (hbefore : MonitoredAccounting state) (hbank : MonitoredBankComplete key required state)
+    (result : Option Result × MonitoredState inputs)
+    (hresult : monitoredRun key inputs hencoding words publicReplies selections rows budget required stopAfter
+      (OracleSpec.query input >>= next) state result ≠ 0)
+    (hcost : result.2.1.memory.external.hashCalls ≤ budget) (hlog : result.2.1.memory.log.length ≤ signatureLimit)
+    (halive : state.2.stopped = false) :
+    ValidSigningStep state.2.log input ∧ signingMacroHashCost input ≤ budget - state.2.spent := by
+  rw [monitoredRun_query_bind, RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨⟨answer, after⟩, hstep, hresult⟩ := hresult
+  obtain ⟨haccount, hstepCost, hstepLog⟩ := monitoredStep_accounting key inputs hencoding words publicReplies selections rows budget required stopAfter
+    input state hvalid ((requestInputs_subset key input next).trans hinputs) hbefore (answer, after) hstep
+  have hfuture : after.1.memory.external.hashCalls ≤ result.2.1.memory.external.hashCalls ∧
+      after.1.memory.log.length ≤ result.2.1.memory.log.length := by
+    cases answer with
+    | none =>
+        simp only [Option.elim_none, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+        subst result
+        exact ⟨le_refl _, le_refl _⟩
+    | some answer =>
+        exact (monitoredRun_accounting key inputs hencoding words publicReplies selections rows budget required stopAfter
+          (next answer) after
+          (monitoredStep_valid key inputs hencoding words publicReplies selections rows budget required stopAfter input state hvalid (some answer, after) hstep)
+          ((sourceInputs_next_subset key input next answer).trans hinputs) haccount result hresult).2
+  have havailable := hstepCost.trans (hfuture.1.trans hcost)
+  have hcap := hfuture.2.trans hlog
+  rw [hstepLog] at hcap
+  constructor
+  · rw [(hbank halive).1]
+    cases input <;> simp only [ValidSigningStep, Sum.isRight, Bool.false_eq_true, if_false, if_true, Nat.add_zero] at hcap ⊢ <;> omega
+  · rw [hbefore halive]
+    omega
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualBankCompleteness.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualBankCompleteness.lean
new file mode 100644
index 000000000..082bcc81c
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualBankCompleteness.lean
@@ -0,0 +1,181 @@
+import SphincsSecurity.Proof.Fts.CertificateBankCompleteness
+import SphincsSecurity.Proof.Residual.RetainedResidualOriginalBudget
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs sourceInputs
+  signDigestLoop signAfterDigest
+set_option backward.isDefEq.respectTransparency false
+
+def MonitoredBankComplete {inputs : Finset HashInput} (key : SecretKey) (required : Finset FtsTree)
+    (state : MonitoredState inputs) : Prop :=
+  state.2.stopped = false → state.2.log = state.1.memory.log ∧ CertificateBankComplete key required (monitorView state)
+
+private theorem update_active_of_alive (key : SecretKey) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : CertificateStopRule) (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState)
+    (length : Nat) (record : ProposalExecutionRecord input)
+    (halive : (certificateMonitorUpdate key budget required stopAfter input state length record).stopped = false) :
+    CertificateMonitorActive key budget input state := by
+  by_contra h
+  rw [certificateMonitorUpdate_inactive key budget required stopAfter input state length record h] at halive
+  contradiction
+
+private theorem update_log_of_alive (key : SecretKey) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : CertificateStopRule) (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState)
+    (length : Nat) (record : ProposalExecutionRecord input)
+    (halive : (certificateMonitorUpdate key budget required stopAfter input state length record).stopped = false) :
+    (certificateMonitorUpdate key budget required stopAfter input state length record).log =
+      (proposalRecordLogState input state.2.log record).2 := by
+  rw [certificateMonitorUpdate, if_pos (update_active_of_alive key budget required stopAfter input state length record halive)]
+
+theorem monitoredWorldResult_bank_complete {inputs : Finset HashInput} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule) (input : OracleWorld.Domain)
+    (before : MonitoredState inputs) (hbefore : MonitoredBankComplete key required before)
+    (result : Option (OracleWorld.Range input) × State inputs) (hlog : result.2.memory.log = before.1.memory.log) :
+    MonitoredBankComplete key required (monitoredWorldResult key budget required stopAfter input before result).2 := by
+  rcases result with ⟨answer, after⟩
+  change after.memory.log = before.1.memory.log at hlog
+  cases answer with
+  | none => intro halive; cases halive
+  | some answer =>
+      intro halive
+      have hactive := update_active_of_alive key budget required stopAfter (.inl input) (monitorView before) 0
+        (proposalOfWorldResult key.parameter input (answer, after.memory.external.cache)) halive
+      have hlogBefore := (hbefore hactive.1).1
+      constructor
+      · have h := update_log_of_alive key budget required stopAfter (.inl input) (monitorView before) 0
+          (proposalOfWorldResult key.parameter input (answer, after.memory.external.cache)) halive
+        simpa only [proposalRecordLogState, signingLogFragment, List.append_nil, monitorView,
+          monitoredWorldResult, Option.elim_some, hlogBefore, hlog] using h
+      · exact certificateMonitorUpdate_bank_complete key budget required stopAfter (.inl input) (monitorView before) 0
+          (proposalOfWorldResult key.parameter input (answer, after.memory.external.cache)) halive
+
+theorem monitoredSigningResult_bank_complete {inputs : Finset HashInput} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule) (message : Message) (annotation : Nat × Index)
+    (before : MonitoredState inputs) (hbefore : MonitoredBankComplete key required before)
+    (result : Option SigningRecord × State inputs) (hlog : result.2.memory.log = before.1.memory.log) :
+    MonitoredBankComplete key required (monitoredSigningResult key budget required stopAfter message annotation before result).2 := by
+  rcases result with ⟨record, after⟩
+  change after.memory.log = before.1.memory.log at hlog
+  cases record with
+  | none => intro halive; cases halive
+  | some record =>
+      intro halive
+      have hactive := update_active_of_alive key budget required stopAfter (.inr message) (monitorView before) annotation.1
+        (proposalOfSigningRecord message record after.memory.external.cache (record.1.2.elim annotation.2 Prod.fst)) halive
+      have hlogBefore := (hbefore hactive.1).1
+      constructor
+      · have h := update_log_of_alive key budget required stopAfter (.inr message) (monitorView before) annotation.1
+          (proposalOfSigningRecord message record after.memory.external.cache (record.1.2.elim annotation.2 Prod.fst)) halive
+        simpa only [proposalRecordLogState, signingLogFragment, proposalOfSigningRecord, monitorView,
+          monitoredSigningResult, Memory.recordSigning, hlogBefore, hlog] using h
+      · exact certificateMonitorUpdate_bank_complete key budget required stopAfter (.inr message) (monitorView before) annotation.1
+          (proposalOfSigningRecord message record after.memory.external.cache (record.1.2.elim annotation.2 Prod.fst)) halive
+
+variable (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+  (words : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem lazyRun_embed_log {Result : Type} (routing : Routing)
+    (computation : OracleComp (ResidualByteFrontend.World inputs) Result) (state : State inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty) (result : Option Result × State inputs)
+    (hresult : lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+      (simulateQ (embed inputs routing) computation) state result ≠ 0) : result.2.memory.log = state.memory.log := by
+  rw [← run_erasure _ _ state ha, RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨actual, _, hresult⟩ := hresult
+  rw [RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨seed, _, hresult⟩ := hresult
+  exact congrArg (fun history => history.2.1)
+    (observedRun_embed_history key.parameter inputs hencoding words publicReplies selections rows routing actual seed computation state result hresult)
+
+theorem lazyRun_externalProgram_log {Result : Type} (computation : OracleComp OracleWorld Result) (state : State inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty) (result : Option Result × State inputs)
+    (hresult : lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+      (externalProgram inputs key.parameter words selections computation) state result ≠ 0) : result.2.memory.log = state.memory.log := by
+  rw [externalProgram, lazyRun_routing_bind] at hresult
+  exact lazyRun_embed_log key inputs hencoding words publicReplies selections rows _ _ state ha result hresult
+
+variable (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+theorem monitoredStep_bank_complete (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState inputs)
+    (ha : ∀ coordinate, (state.1.candidates coordinate).Nonempty) (hbefore : MonitoredBankComplete key required state)
+    (result : Option ((OracleWorld + SigningSpec).Range input) × MonitoredState inputs)
+    (hresult : monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state result ≠ 0) :
+    MonitoredBankComplete key required result.2 := by
+  cases input with
+  | inl input =>
+      rw [monitoredStep, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨raw, hraw, hresult⟩ := hresult
+      simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact monitoredWorldResult_bank_complete key budget required stopAfter input state hbefore raw
+        (lazyRun_externalProgram_log key inputs hencoding words publicReplies selections rows _ state.1 ha raw hraw)
+  | inr message =>
+      rw [monitoredStep, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨annotation, _, hresult⟩ := hresult
+      rw [map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨raw, hraw, hresult⟩ := hresult
+      simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact monitoredSigningResult_bank_complete key budget required stopAfter message annotation state hbefore raw
+        (lazyRun_embed_log key inputs hencoding words publicReplies selections rows _ _ state.1 ha raw hraw)
+
+theorem monitoredRun_bank_complete {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : MonitoredState inputs) (hvalid : MonitoredValid inputs state) (hbefore : MonitoredBankComplete key required state)
+    (result : Option Result × MonitoredState inputs)
+    (hresult : monitoredRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state result ≠ 0) :
+    MonitoredBankComplete key required result.2 := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value =>
+      simp only [monitoredRun_pure, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact hbefore
+  | query_bind input next ih =>
+      rw [monitoredRun_query_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨⟨answer, after⟩, hafter, hresult⟩ := hresult
+      have hbank := monitoredStep_bank_complete key inputs hencoding words publicReplies selections rows budget required stopAfter
+        input state hvalid.1 hbefore (answer, after) hafter
+      have hvalid' := monitoredStep_valid key inputs hencoding words publicReplies selections rows budget required stopAfter
+        input state hvalid (answer, after) hafter
+      cases answer with
+      | none =>
+          simp only [Option.elim_none, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          subst result
+          exact hbank
+      | some answer => exact ih answer after hvalid' hbank hresult
+
+theorem monitoredBankComplete_initial (exposed : InitialPublicLabels words) (spent : Nat) (stopped : Bool) :
+    MonitoredBankComplete key required (initialState inputs words exposed, initialCertificateMonitor spent stopped) := by
+  intro _
+  exact ⟨rfl, initialCertificateMonitor_bank_complete key spent required _ stopped (fun _ _ => rfl)⟩
+
+theorem initialMonitoredSource_bank_complete (adversary : Adversary) (encoding : ReferenceEncodingAuxiliary)
+    (dummy : OtsReferenceWords) (exposed : InitialPublicLabels (referenceFamilyWords encoding.selections dummy))
+    (high : CanonicalGraphHighHalves) (stopped : Bool)
+    (result : Option (Forgery × Bool) × MonitoredState (gameInputs adversary))
+    (hresult : initialMonitoredSource key adversary encoding dummy exposed high budget required stopAfter stopped result ≠ 0) :
+    MonitoredBankComplete key required result.2 := by
+  exact monitoredRun_bank_complete key (gameInputs adversary) (canonicalEncodingInputs_subset_retainedGameInputs adversary key.parameter)
+    (referenceFamilyWords encoding.selections dummy)
+    (coordinateGraphLabels (initialKnown (referenceFamilyWords encoding.selections dummy) exposed) high)
+    encoding.selections encoding.rows budget required stopAfter _ _
+    ⟨initialAllowed_nonempty _ exposed, initialState_rowsCovered _ _ exposed⟩
+    (monitoredBankComplete_initial key _ _ required exposed 1212415 stopped) result hresult
+
+theorem initialMonitoredSource_certificate_count (adversary : Adversary) (encoding : ReferenceEncodingAuxiliary)
+    (dummy : OtsReferenceWords) (exposed : InitialPublicLabels (referenceFamilyWords encoding.selections dummy))
+    (high : CanonicalGraphHighHalves) (stopped : Bool)
+    (result : Option (Forgery × Bool) × MonitoredState (gameInputs adversary))
+    (hresult : initialMonitoredSource key adversary encoding dummy exposed high budget required stopAfter stopped result ≠ 0)
+    (halive : result.2.2.stopped = false) (input : HashInput)
+    (hcertificate : TargetCertificateAt key required (result.2.1.memory.external.cache, result.2.1.memory.log) input) :
+    1 ≤ certificateBankCount result.2.2.bank := by
+  obtain ⟨hlog, hbank⟩ := initialMonitoredSource_bank_complete key budget required stopAfter adversary encoding dummy exposed high stopped result hresult halive
+  apply one_le_certificateBankCount _ input
+  apply hbank input
+  change TargetCertificateAt key required (result.2.1.memory.external.cache, result.2.2.log) input
+  rwa [hlog]
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualBoundaryCost.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualBoundaryCost.lean
new file mode 100644
index 000000000..0b09852d4
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualBoundaryCost.lean
@@ -0,0 +1,238 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.ResidualSigningProgram
+import SphincsSecurity.Proof.Residual.RetainedResidualSigningKernel
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs
+set_option backward.isDefEq.respectTransparency false
+
+theorem messageState_memory (parameter : PublicParameter) {inputs : Finset HashInput} (state : State inputs)
+    (input : inputs) (answer : HashOutput) (hm : FtsProbeSimulation.MessageHashInput parameter input.val) :
+    (messageState parameter state input answer).memory =
+      state.memory.applyBoundary (signingBoundaryTrace parameter (.inr input.val) answer) := by
+  simp only [messageState, Memory.applyBoundary, Memory.observeMessage, signingBoundaryTrace, if_pos hm]
+  rfl
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+  (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem lazyByteRun_map {A B : Type} (routing : Routing) (f : A → B)
+    (computation : OracleComp OracleWorld A) (state : State inputs) :
+    lazyByteRun parameter inputs hencoding words publicReplies selections rows routing (f <$> computation) state =
+      Prod.map (Option.map f) id <$> lazyByteRun parameter inputs hencoding words publicReplies selections rows routing computation state := by
+  simp only [lazyByteRun, simulateQ_map, lazyRun, runWith, OptionT.run_map, StateT.run_map]
+  rfl
+
+attribute [local irreducible] lazyRun environment lazyByteRun
+
+theorem lazyByteRun_boundary_memory {Result : Type} (routing : Routing)
+    (computation : OracleComp OracleWorld Result) (hinputs : hashInputs computation ⊆ inputs)
+    (hmessage : ResidualByteFrontend.MessageOnly parameter computation) (state : State inputs)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (result : Option (Result × SigningBoundaryTrace) × State inputs)
+    (hresult : lazyByteRun parameter inputs hencoding words publicReplies selections rows routing
+      (boundaryComputation parameter computation) state result ≠ 0) :
+    ∃ record, result.1 = some record ∧ result.2.memory = state.memory.applyBoundary record.2 := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      have hp : boundaryComputation parameter (pure value) = pure (value, 1) := by
+        simp only [boundaryComputation, simulateQ_pure, WriterT.run_pure]
+      rw [hp, lazyByteRun_pure] at hresult
+      simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact ⟨(value, 1), rfl, (applyBoundary_one state.memory).symm⟩
+  | query_bind input next ih =>
+      have hnext : ∀ answer, hashInputs (next answer) ⊆ inputs :=
+        fun answer => (hashInputs_next_subset input next answer).trans hinputs
+      have hmnext : ∀ answer, ResidualByteFrontend.MessageOnly parameter (next answer) :=
+        fun answer row hrow => hmessage row ((hashInputs_next_subset input next answer) hrow)
+      rw [ResidualByteFrontend.boundaryComputation_query_bind] at hresult
+      cases input with
+      | inl input =>
+          rw [lazyByteRun_random_bind, RetainedObservation.bind_nonzero] at hresult
+          obtain ⟨answer, _, hresult⟩ := hresult
+          rw [lazyByteRun_map, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+          obtain ⟨raw, hraw, hresult⟩ := hresult
+          obtain ⟨record, hr, hmemory⟩ := ih answer (hnext answer) (hmnext answer) state hcovered raw hraw
+          simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          subst result
+          have heq : raw = (some record, raw.2) := Prod.ext hr rfl
+          rw [heq]
+          exact ⟨record, rfl, hmemory⟩
+      | inr input =>
+          change HashOutput → OracleComp OracleWorld Result at next
+          have hin := hinputs (mem_hashInputs_hash_bind input next)
+          have hm := hmessage input (mem_hashInputs_hash_bind input next)
+          rw [lazyByteRun_message_bind parameter inputs hencoding words publicReplies selections rows routing input hin hm _ state hcovered,
+            RetainedObservation.bind_nonzero] at hresult
+          obtain ⟨reply, hreply, hresult⟩ := hresult
+          obtain ⟨_, hrows⟩ := randomOracle_messageState parameter inputs state hcovered ⟨input, hin⟩ reply
+            ((mem_support_iff _ _).mpr hreply)
+          rw [lazyByteRun_map, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+          obtain ⟨raw, hraw, hresult⟩ := hresult
+          obtain ⟨record, hr, hmemory⟩ := ih reply.1 (hnext reply.1) (hmnext reply.1) _ hrows raw hraw
+          simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          subst result
+          have heq : raw = (some record, raw.2) := Prod.ext hr rfl
+          rw [heq]
+          refine ⟨(record.1, signingBoundaryTrace parameter (.inr input) reply.1 * record.2), rfl, ?_⟩
+          change raw.2.memory = state.memory.applyBoundary (signingBoundaryTrace parameter (.inr input) reply.1 * record.2)
+          rw [hmemory, messageState_memory parameter state ⟨input, hin⟩ reply.1 hm, ← applyBoundary_mul]
+
+theorem digestWork_memory (known : Labels) (words : OtsReferenceWords) (selections : ReferenceFamily)
+    (selected : Option (Randomness × Index × (IndexGroup → FtsLeaf)) × SigningBoundaryTrace) (memory : Memory) :
+    (memory.applyBoundary selected.2).accountWork (digestWork known words selections selected).2 =
+      memory.applyBoundary (digestWork known words selections selected).1.2 := by
+  rcases selected with ⟨selected, trace⟩
+  cases selected with
+  | none =>
+      simp only [digestWork, Memory.accountWork, ResidualByteFrontend.accountWork, Nat.add_zero]
+  | some selected =>
+      simp only [digestWork, applyBoundary_mul, applyBoundary_pow_none]
+
+theorem lazyByteRun_publicSigningWork_memory (routing : Routing) (root : Digest) (message : Message)
+    (hinputs : hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs)
+    (state : State inputs) (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (result : Option (PublicSigningRecord × Nat) × State inputs)
+    (hresult : lazyByteRun parameter inputs hencoding words publicReplies selections rows routing
+      (ResidualByteFrontend.publicSigningWork parameter root routing.known words selections message) state result ≠ 0) :
+    ∃ work, result.1 = some work ∧ result.2.memory.accountWork work.2 = state.memory.applyBoundary work.1.2 := by
+  rw [publicSigningWork_eq_digestWork, lazyByteRun_map, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨raw, hraw, hresult⟩ := hresult
+  obtain ⟨record, hr, hmemory⟩ := lazyByteRun_boundary_memory parameter inputs hencoding words publicReplies selections rows routing
+    (publicDigestLoop parameter root message digestAttemptLimit) hinputs
+    (ResidualByteFrontend.messageOnly_publicDigestLoop parameter root message digestAttemptLimit) state hcovered raw hraw
+  simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+  subst result
+  have heq : raw = (some record, raw.2) := Prod.ext hr rfl
+  rw [heq]
+  refine ⟨digestWork routing.known words selections record, rfl, ?_⟩
+  change raw.2.memory.accountWork _ = _
+  rw [hmemory, digestWork_memory]
+
+theorem lazyRun_jointSigningProgram_memory_trace (routing : Routing) (root : Digest) (message : Message)
+    (hinputs : hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs)
+    (state : State inputs) (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (result : Option SigningRecord × State inputs)
+    (hresult : lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+      (simulateQ (embed inputs routing)
+        (ResidualByteFrontend.jointSigningProgram inputs parameter root routing.known words selections message)) state result ≠ 0) :
+    ∃ record, result.1 = some record ∧ result.2.memory = state.memory.applyBoundary record.2 := by
+  rw [ResidualByteFrontend.jointSigningProgram, simulateQ_bind, lazyRun_bind, RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨middle, hmiddle, hresult⟩ := hresult
+  rw [← lazyByteRun] at hmiddle
+  obtain ⟨work, hw, hpaid⟩ := lazyByteRun_publicSigningWork_memory parameter inputs hencoding words publicReplies selections rows
+    routing root message hinputs state hcovered middle hmiddle
+  have hcandidates := (lazyByteRun_message_support parameter inputs hencoding words publicReplies selections rows routing
+    (ResidualByteFrontend.publicSigningWork parameter root routing.known words selections message)
+    (by simpa only [ResidualByteFrontend.hashInputs_publicSigningWork] using hinputs)
+    (ResidualByteFrontend.publicSigningWork_messageOnly parameter root routing.known words selections message)
+    state hcovered middle hmiddle).2
+  have ha' : ∀ coordinate, (middle.2.candidates coordinate).Nonempty := by rw [hcandidates]; exact ha
+  rw [hw, Option.elim_some] at hresult
+  obtain ⟨actual, hr, hmemory⟩ := lazyRun_completeWork_support parameter inputs hencoding words publicReplies selections rows
+    routing work middle.2 ha' result hresult
+  exact ⟨_, hr, by rw [hmemory, completePublicSigningRecord_trace]; exact hpaid⟩
+
+theorem checkedHashResult_hashCalls (routing : Routing) (actual : Labels) (seed : inputs → HashOutput)
+    (input : inputs) (state : State inputs) :
+    (checkedHashResult parameter inputs hencoding words publicReplies selections rows routing actual seed input state).2.memory.external.hashCalls =
+      state.memory.external.hashCalls + 1 := by
+  have hp := congrArg (fun result : Option HashOutput × ResidualByteFrontend.State inputs => result.2.memory.hashCalls)
+    (hashResult_project parameter inputs hencoding words publicReplies selections rows routing actual seed input state)
+  change (hashResult parameter inputs hencoding words publicReplies selections rows routing actual seed input state).2.memory.external.hashCalls = _
+  exact hp.trans (ResidualByteFrontend.hashQueryResult_hashCalls parameter inputs words routing.disclosed routing.known
+    (ResidualByteAction.freshPrefix parameter inputs hencoding words routing.disclosed routing.known publicReplies selections rows)
+    actual seed input (project state))
+
+theorem lazyByteRun_hash_result (routing : Routing) (input : HashInput) (hin : input ∈ inputs)
+    (state : State inputs) (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (result : Option HashOutput × State inputs)
+    (hresult : lazyByteRun parameter inputs hencoding words publicReplies selections rows routing
+      (liftM (OracleWorld.query (.inr input))) state result ≠ 0) :
+    ∃ actual seed, result = checkedHashResult parameter inputs hencoding words publicReplies selections rows routing actual seed ⟨input, hin⟩ state := by
+  unfold lazyByteRun at hresult
+  rw [← run_erasure _ _ state ha, RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨actual, _, hresult⟩ := hresult
+  rw [RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨seed, _, hresult⟩ := hresult
+  simp only [simulateQ_spec_query, ResidualByteFrontend.checkedTranslate, dif_pos hin] at hresult
+  rw [observedRun_checkedHashQuery parameter inputs hencoding words publicReplies selections rows routing actual seed
+    ⟨input, hin⟩ state] at hresult
+  simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+  subst result
+  exact ⟨actual, seed, rfl⟩
+
+theorem lazyByteRun_hash_hashCalls (routing : Routing) (input : HashInput) (hin : input ∈ inputs)
+    (state : State inputs) (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (result : Option HashOutput × State inputs)
+    (hresult : lazyByteRun parameter inputs hencoding words publicReplies selections rows routing
+      (liftM (OracleWorld.query (.inr input))) state result ≠ 0) :
+    result.2.memory.external.hashCalls = state.memory.external.hashCalls + 1 := by
+  obtain ⟨actual, seed, rfl⟩ := lazyByteRun_hash_result parameter inputs hencoding words publicReplies selections rows routing input hin state ha result hresult
+  exact checkedHashResult_hashCalls parameter inputs hencoding words publicReplies selections rows routing actual seed ⟨input, hin⟩ state
+
+theorem lazyByteRun_world_hashCalls (routing : Routing) (input : OracleWorld.Domain)
+    (hinputs : hashInputs (liftM (OracleWorld.query input)) ⊆ inputs)
+    (state : State inputs) (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (result : Option (OracleWorld.Range input) × State inputs)
+    (hresult : lazyByteRun parameter inputs hencoding words publicReplies selections rows routing
+      (liftM (OracleWorld.query input)) state result ≠ 0) :
+    result.2.memory.external.hashCalls = state.memory.external.hashCalls + if input matches .inr _ then 1 else 0 := by
+  cases input with
+  | inl input =>
+      rw [← bind_pure (liftM (OracleWorld.query (.inl input))), lazyByteRun_random_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨answer, _, hresult⟩ := hresult
+      rw [lazyByteRun_pure] at hresult
+      simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact (Nat.add_zero _).symm
+  | inr input =>
+      apply lazyByteRun_hash_hashCalls parameter inputs hencoding words publicReplies selections rows routing input _ state ha result hresult
+      apply hinputs
+      rw [← bind_pure (liftM (OracleWorld.query (.inr input)))]
+      exact mem_hashInputs_hash_bind input pure
+
+theorem lazyByteRun_world_messageTrace (routing : Routing) (input : OracleWorld.Domain)
+    (hinputs : hashInputs (liftM (OracleWorld.query input)) ⊆ inputs)
+    (state : State inputs) (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (result : Option (OracleWorld.Range input) × State inputs)
+    (hresult : lazyByteRun parameter inputs hencoding words publicReplies selections rows routing
+      (liftM (OracleWorld.query input)) state result ≠ 0) :
+    result.2.memory.messageCalls = state.memory.messageCalls ++
+      result.1.elim [] (fun answer => (signingBoundaryTrace parameter input answer).messageCalls) := by
+  cases input with
+  | inl input =>
+      rw [← bind_pure (liftM (OracleWorld.query (.inl input))), lazyByteRun_random_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨answer, _, hresult⟩ := hresult
+      rw [lazyByteRun_pure] at hresult
+      simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact (List.append_nil _).symm
+  | inr input =>
+      have hin : input ∈ inputs := by
+        apply hinputs
+        rw [← bind_pure (liftM (OracleWorld.query (.inr input)))]
+        exact mem_hashInputs_hash_bind input pure
+      obtain ⟨actual, seed, rfl⟩ := lazyByteRun_hash_result parameter inputs hencoding words publicReplies selections rows routing input hin state ha result hresult
+      have h := checkedHashResult_memory parameter inputs hencoding words publicReplies selections rows routing actual seed ⟨input, hin⟩ state
+      dsimp only at h
+      have hmessages := congrArg Memory.messageCalls h
+      apply hmessages.trans
+      generalize (checkedHashResult parameter inputs hencoding words publicReplies selections rows routing actual seed ⟨input, hin⟩ state).1 = answer
+      cases answer with
+      | none => simp only [Memory.afterReply, Option.elim_none, List.append_nil]
+      | some answer =>
+          by_cases hm : FtsProbeSimulation.MessageHashInput parameter input
+          · simp only [Memory.afterReply, Option.elim_some, Memory.observeMessage, signingBoundaryTrace, if_pos hm]
+            rfl
+          · simp only [Memory.afterReply, Option.elim_some, Memory.observeMessage, signingBoundaryTrace, if_neg hm]
+            exact (List.append_nil _).symm
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualBudget.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualBudget.lean
new file mode 100644
index 000000000..365515b76
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualBudget.lean
@@ -0,0 +1,130 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualComposition
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs sourceInputs canonicalEncodingInputs canonicalGraphInputs
+set_option backward.isDefEq.respectTransparency false
+
+theorem fixedBoundaryRun_bind_query_bound {A B : Type} (parameter : PublicParameter) (oracle : QueryImpl HashSpec Id)
+    (computation : OracleComp OracleWorld A) (next : A → OracleComp OracleWorld B) (q : Nat)
+    (hbound : (computation >>= next).IsQueryBoundP (· matches .inr _) q)
+    (result : A × SigningBoundaryTrace) (hresult : 𝒟[fixedBoundaryRun parameter oracle computation] result ≠ 0) :
+    result.2.hashCalls ≤ q ∧ (next result.1).IsQueryBoundP (· matches .inr _) (q - result.2.hashCalls) := by
+  induction computation using OracleComp.inductionOn generalizing q result with
+  | pure value =>
+      simp only [fixedBoundaryRun_pure, evalDist_pure, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      simpa only [SigningBoundaryTrace.hashCalls, FreeMonoid.toList_one, List.length_nil, Nat.sub_zero, pure_bind] using
+        And.intro (Nat.zero_le q) hbound
+  | query_bind input continuation ih =>
+      rw [bind_assoc, isQueryBoundP_query_bind_iff] at hbound
+      rw [ResidualByteFrontend.fixedBoundaryRun_query_bind, evalDist_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨answer, _, hresult⟩ := hresult
+      rw [evalDist_map, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨tail, htail, hresult⟩ := hresult
+      simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      have h := ih answer _ (hbound.2 answer) tail htail
+      rw [SigningBoundaryTrace.hashCalls_mul, signingBoundaryTrace_hashCalls_eq]
+      cases input with
+      | inl input => simpa only [Bool.false_eq_true, ↓reduceIte, Nat.sub_zero, Nat.zero_add] using h
+      | inr input =>
+          have hpositive : 0 < q := hbound.1.resolve_left (by simp)
+          simp only [↓reduceIte] at h ⊢
+          exact ⟨by omega, by simpa only [Nat.sub_sub] using h.2⟩
+
+theorem fixedHashStep_hashCalls (parameter : PublicParameter) (words : OtsReferenceWords) (selections : ReferenceFamily)
+    (routing : InterleavedResidual.Routing) (actual : Labels) (oracle : QueryImpl HashSpec Id) (input : HashInput) (memory : Memory) :
+    (fixedHashStep parameter words selections routing actual oracle input memory).2.external.hashCalls = memory.external.hashCalls + 1 := by
+  rw [fixedHashStep_external]
+  exact ResidualByteFrontend.fixedStep_hashCalls parameter words routing.disclosed routing.known actual oracle input memory.external
+
+theorem applyBoundary_recordSigning_hashCalls (memory : Memory) (message : Message) (record : InterleavedResidual.SigningRecord) :
+    ((memory.applyBoundary record.2).recordSigning message record).external.hashCalls = memory.external.hashCalls + record.2.hashCalls := rfl
+
+theorem fixedSourceImpl_query_bound {Result : Type} {inputs : Finset HashInput} (context : Context inputs)
+    (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Result)
+    (q : Nat) (hbound : (simulateQ (expandedAdversaryImpl context.key)
+      (liftM ((OracleWorld + SigningSpec).query input) >>= next)).IsQueryBoundP (· matches .inr _) q)
+    (memory : Memory) (result : Option ((OracleWorld + SigningSpec).Range input) × Memory)
+    (hresult : (fixedSourceImpl context input).run.run memory result ≠ 0) :
+    ∃ cost ≤ q, result.2.external.hashCalls = memory.external.hashCalls + cost ∧
+      ∀ answer, result.1 = some answer →
+        (simulateQ (expandedAdversaryImpl context.key) (next answer)).IsQueryBoundP (· matches .inr _) (q - cost) := by
+  cases input with
+  | inl input =>
+      rw [simulateQ_expandedAdversaryImpl_query_bind_inl, isQueryBoundP_query_bind_iff] at hbound
+      simp only [fixedSourceImpl, OptionT.run_mk, StateT.run_mk, fixedByteRun, simulateQ_spec_query] at hresult
+      cases input with
+      | inl input =>
+          simp only [fixedByteImpl, OptionT.run_mk, StateT.run_mk, RetainedObservation.bind_nonzero] at hresult
+          obtain ⟨value, _, hresult⟩ := hresult
+          simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          subst result
+          refine ⟨0, Nat.zero_le _, (Nat.add_zero _).symm, ?_⟩
+          intro answer heq
+          cases Option.some.inj heq
+          exact hbound.2 value
+      | inr input =>
+          simp only [fixedByteImpl, OptionT.run_mk, StateT.run_mk, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          subst result
+          have hpositive : 0 < q := hbound.1.resolve_left (by simp)
+          refine ⟨1, hpositive, fixedHashStep_hashCalls _ _ _ _ _ _ _ _, ?_⟩
+          intro answer _
+          exact hbound.2 answer
+  | inr message =>
+      rw [simulateQ_expandedAdversaryImpl_query_bind_inr] at hbound
+      change (sign context.key message >>= _).IsQueryBoundP (· matches .inr _) q at hbound
+      rw [← signWithView_fst context.key message, bind_map_left] at hbound
+      simp only [fixedSourceImpl, OptionT.run_mk, StateT.run_mk, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨record, hrecord, hresult⟩ := hresult
+      simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      have h := fixedBoundaryRun_bind_query_bound context.key.parameter context.oracle (signWithView context.key message)
+        (fun reply => simulateQ (expandedAdversaryImpl context.key) (next reply.1)) q hbound record hrecord
+      refine ⟨record.2.hashCalls, h.1, applyBoundary_recordSigning_hashCalls memory message record, ?_⟩
+      intro answer heq
+      cases Option.some.inj heq
+      exact h.2
+
+theorem fixedSourceRun_hashCalls_le {Result : Type} {inputs : Finset HashInput} (context : Context inputs)
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) (q : Nat)
+    (hbound : (simulateQ (expandedAdversaryImpl context.key) computation).IsQueryBoundP (· matches .inr _) q)
+    (memory : Memory) (result : Option Result × Memory) (hresult : fixedSourceRun context computation memory result ≠ 0) :
+    result.2.external.hashCalls ≤ memory.external.hashCalls + q := by
+  induction computation using OracleComp.inductionOn generalizing q memory result with
+  | pure value =>
+      simp only [fixedSourceRun_pure, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact Nat.le_add_right _ _
+  | query_bind input next ih =>
+      rw [fixedSourceRun_query_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨⟨answer, middle⟩, hmiddle, hresult⟩ := hresult
+      obtain ⟨cost, hcost, hpaid, hnext⟩ := fixedSourceImpl_query_bound context input next q hbound memory (answer, middle) hmiddle
+      cases answer with
+      | none =>
+          simp only [Option.elim_none, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          subst result
+          exact hpaid.trans_le (Nat.add_le_add_left hcost _)
+      | some answer =>
+          have h := ih answer (q - cost) (hnext answer rfl) middle result hresult
+          rw [hpaid] at h
+          omega
+
+theorem observedRun_source_hashCalls_le {Result : Type} {inputs : Finset HashInput} (context : Context inputs)
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) (hinputs : sourceInputs context.key computation ⊆ inputs)
+    (q : Nat) (hbound : (simulateQ (expandedAdversaryImpl context.key) computation).IsQueryBoundP (· matches .inr _) q)
+    (state : State inputs) (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hcompatible : Compatible context state.memory) (result : Option Result × State inputs)
+    (hresult : observedRun context.environment context.actual context.auxiliary.seed
+      (simulateQ (adversaryImpl inputs context.key.parameter context.key.root context.words context.auxiliary.selections) computation) state result ≠ 0) :
+    result.2.memory.external.hashCalls ≤ state.memory.external.hashCalls + q := by
+  have h := map_nonzero _ forgetState result hresult
+  rw [observedRun_source_memory context computation hinputs state hcovered hcompatible] at h
+  exact fixedSourceRun_hashCalls_le context computation q hbound state.memory (forgetState result) h
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualByteRun.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualByteRun.lean
new file mode 100644
index 000000000..34ad7abe0
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualByteRun.lean
@@ -0,0 +1,142 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualCheckedTrace
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting ResidualByteAction
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs
+set_option backward.isDefEq.respectTransparency false
+
+def forgetState {Result : Type} {inputs : Finset HashInput} (result : Option Result × State inputs) : Option Result × Memory :=
+  (result.1, result.2.memory)
+
+theorem afterReply_external (parameter : PublicParameter) (memory : Memory) (input : HashInput)
+    (answer : Option HashOutput) (external : ExternalMemory) :
+    (memory.afterReply parameter input answer external).external = external := by
+  cases answer with
+  | none => rfl
+  | some answer => exact observeMessage_external parameter _ _ _
+
+noncomputable def fixedByteImpl (parameter : PublicParameter) (words : OtsReferenceWords) (selections : ReferenceFamily)
+    (routing : Routing) (actual : Labels) (oracle : QueryImpl HashSpec Id) : QueryImpl OracleWorld (OptionT (StateT Memory SPMF))
+  | .inl input => OptionT.mk <| StateT.mk fun memory =>
+      (liftM (PMF.uniformOfFintype (unifSpec.Range input)) : SPMF _) >>= fun answer => pure (some answer, memory)
+  | .inr input => OptionT.mk <| StateT.mk fun memory => pure (fixedHashStep parameter words selections routing actual oracle input memory)
+
+noncomputable def fixedByteRun {Result : Type} (parameter : PublicParameter) (words : OtsReferenceWords) (selections : ReferenceFamily)
+    (routing : Routing) (actual : Labels) (oracle : QueryImpl HashSpec Id) (computation : OracleComp OracleWorld Result) (memory : Memory) :
+    SPMF (Option Result × Memory) :=
+  (OptionT.run (simulateQ (fixedByteImpl parameter words selections routing actual oracle) computation)).run memory
+
+theorem fixedByteRun_pure {Result : Type} (parameter : PublicParameter) (words : OtsReferenceWords) (selections : ReferenceFamily)
+    (routing : Routing) (actual : Labels) (oracle : QueryImpl HashSpec Id) (value : Result) (memory : Memory) :
+    fixedByteRun parameter words selections routing actual oracle (pure value) memory = pure (some value, memory) := by
+  simp only [fixedByteRun, simulateQ_pure, OptionT.run_pure, StateT.run_pure]
+
+theorem fixedByteRun_query_bind {Result : Type} (parameter : PublicParameter) (words : OtsReferenceWords) (selections : ReferenceFamily)
+    (routing : Routing) (actual : Labels) (oracle : QueryImpl HashSpec Id) (input : OracleWorld.Domain)
+    (next : OracleWorld.Range input → OracleComp OracleWorld Result) (memory : Memory) :
+    fixedByteRun parameter words selections routing actual oracle (liftM (OracleWorld.query input) >>= next) memory =
+      ((fixedByteImpl parameter words selections routing actual oracle input).run.run memory >>= fun result =>
+        result.1.elim (pure (none, result.2)) (fun answer => fixedByteRun parameter words selections routing actual oracle (next answer) result.2)) := by
+  simp only [fixedByteRun, simulateQ_bind, simulateQ_spec_query, OptionT.run_bind, Option.elimM, StateT.run_bind]
+  apply congrArg (_ >>= ·)
+  funext result
+  rcases result with ⟨answer, after⟩
+  cases answer <;> rfl
+
+theorem fixedHashStep_external (parameter : PublicParameter) (words : OtsReferenceWords) (selections : ReferenceFamily)
+    (routing : Routing) (actual : Labels) (oracle : QueryImpl HashSpec Id) (input : HashInput) (memory : Memory) :
+    (fixedHashStep parameter words selections routing actual oracle input memory).2.external =
+      (ResidualByteFrontend.fixedStep parameter words routing.disclosed routing.known actual oracle input memory.external).2 := by
+  exact afterReply_external parameter memory input _ _
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+  (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+noncomputable def byteRun {Result : Type} (routing : Routing) (actual : Labels) (seed : inputs → HashOutput)
+    (computation : OracleComp OracleWorld Result) (state : State inputs) :=
+  observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+    (simulateQ (embed inputs routing) (simulateQ (ResidualByteFrontend.checkedTranslate inputs
+      (PublicEncodingMatch.Match parameter (knownEncodingMessage routing.known) words selections)) computation)) state
+
+theorem byteRun_pure {Result : Type} (routing : Routing) (actual : Labels) (seed : inputs → HashOutput) (value : Result) (state : State inputs) :
+    byteRun parameter inputs hencoding words publicReplies selections rows routing actual seed (pure value) state = pure (some value, state) := by
+  simp only [byteRun, simulateQ_pure, observedRun, runWith_pure]
+
+theorem byteRun_random_bind {Result : Type} (routing : Routing) (actual : Labels) (seed : inputs → HashOutput)
+    (input : unifSpec.Domain) (next : unifSpec.Range input → OracleComp OracleWorld Result) (state : State inputs) :
+    byteRun parameter inputs hencoding words publicReplies selections rows routing actual seed (liftM (OracleWorld.query (.inl input)) >>= next) state =
+      ((liftM (PMF.uniformOfFintype (unifSpec.Range input)) : SPMF _) >>= fun answer =>
+        byteRun parameter inputs hencoding words publicReplies selections rows routing actual seed (next answer) state) := by
+  simp only [byteRun, simulateQ_bind, simulateQ_spec_query, ResidualByteFrontend.checkedTranslate, embed]
+  rw [observedRun, runWith_query_bind]
+  simp only [observedImpl, environment, ResidualByteFrontend.environment, OptionT.run_mk, StateT.run_mk,
+    ← PMF.monad_map_eq_map, liftM_map, bind_map_left, bind_assoc, pure_bind, Option.elim_some,
+    afterControl, project]
+  rfl
+
+theorem byteRun_hash_bind {Result : Type} (routing : Routing) (actual : Labels) (seed : inputs → HashOutput)
+    (input : HashInput) (hin : input ∈ inputs) (next : HashOutput → OracleComp OracleWorld Result) (state : State inputs) :
+    byteRun parameter inputs hencoding words publicReplies selections rows routing actual seed (liftM (OracleWorld.query (.inr input)) >>= next) state =
+      let result := checkedHashResult parameter inputs hencoding words publicReplies selections rows routing actual seed ⟨input, hin⟩ state
+      result.1.elim (pure (none, result.2)) (fun answer =>
+        byteRun parameter inputs hencoding words publicReplies selections rows routing actual seed (next answer) result.2) := by
+  simp only [byteRun, simulateQ_bind, simulateQ_spec_query, ResidualByteFrontend.checkedTranslate, dif_pos hin]
+  rw [observedRun_bind, observedRun_checkedHashQuery, pure_bind]
+  rfl
+
+theorem checkedHashResult_rowsCovered (routing : Routing) (actual : Labels) (seed : inputs → HashOutput) (input : inputs)
+    (state : State inputs) (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) :
+    ResidualByteFrontend.RowsCovered inputs (project
+      (checkedHashResult parameter inputs hencoding words publicReplies selections rows routing actual seed input state).2) := by
+  have h := ResidualByteFrontend.hashQueryResult_rowsCovered parameter inputs words routing.disclosed routing.known
+    (freshPrefix parameter inputs hencoding words routing.disclosed routing.known publicReplies selections rows)
+    actual seed (project state) hcovered input
+  have heq := congrArg Prod.snd (hashResult_project parameter inputs hencoding words publicReplies selections rows routing actual seed input state)
+  rw [← heq] at h
+  exact h
+
+theorem byteRun_eq_fixed {Result : Type} (routing : Routing) (actual : Labels) (seed : inputs → HashOutput) (oracle : QueryImpl HashSpec Id)
+    (hfresh : ∀ input : inputs, ResidualByteAction.eval actual seed
+      (freshPrefix parameter inputs hencoding words routing.disclosed routing.known publicReplies selections rows input) =
+      ResidualByteFrontend.fixedAnswer parameter words routing.disclosed actual oracle input.val)
+    (computation : OracleComp OracleWorld Result) (hinputs : hashInputs computation ⊆ inputs) (state : State inputs)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hmatches : ResidualByteFrontend.CacheMatches oracle state.memory.external.cache)
+    (hclean : CacheClean parameter words routing.disclosed actual state.memory.external.cache) :
+    forgetState <$> byteRun parameter inputs hencoding words publicReplies selections rows routing actual seed computation state =
+      fixedByteRun parameter words selections routing actual oracle computation state.memory := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [byteRun_pure, fixedByteRun_pure, map_pure, forgetState]
+  | query_bind input next ih =>
+      have hnext : ∀ answer, hashInputs (next answer) ⊆ inputs := fun answer => (hashInputs_next_subset input next answer).trans hinputs
+      cases input with
+      | inl input =>
+          rw [byteRun_random_bind, fixedByteRun_query_bind]
+          simp only [fixedByteImpl, OptionT.run_mk, StateT.run_mk, bind_assoc, pure_bind, Option.elim_some, map_bind]
+          apply congrArg (_ >>= ·)
+          funext answer
+          exact ih answer (hnext answer) state hcovered hmatches hclean
+      | inr input =>
+          change HashOutput → OracleComp OracleWorld Result at next
+          have hin : input ∈ inputs := hinputs (mem_hashInputs_hash_bind input next)
+          rw [byteRun_hash_bind parameter inputs hencoding words publicReplies selections rows routing actual seed input hin, fixedByteRun_query_bind]
+          simp only [fixedByteImpl, OptionT.run_mk, StateT.run_mk, pure_bind]
+          have hstep := checkedHashResult_eq_fixed parameter inputs hencoding words publicReplies selections rows routing actual seed
+            oracle ⟨input, hin⟩ state (hfresh ⟨input, hin⟩) hcovered hmatches hclean
+          dsimp only at hstep
+          have hafter := ResidualByteFrontend.fixedStep_preserves parameter words routing.disclosed routing.known actual oracle input state.memory.external hmatches hclean
+          rw [← fixedHashStep_external parameter words selections routing actual oracle input state.memory, ← hstep] at hafter
+          rw [← hstep]
+          have hcovered' := checkedHashResult_rowsCovered parameter inputs hencoding words publicReplies selections rows routing actual seed ⟨input, hin⟩ state hcovered
+          generalize hresult : checkedHashResult parameter inputs hencoding words publicReplies selections rows routing actual seed ⟨input, hin⟩ state = result at *
+          rcases result with ⟨answer, after⟩
+          cases answer with
+          | none => simp only [Option.elim_none, map_pure, forgetState]
+          | some answer => exact ih answer (hnext answer) after hcovered' hafter.1 hafter.2.1
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCacheAccounting.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCacheAccounting.lean
new file mode 100644
index 000000000..74a80976d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCacheAccounting.lean
@@ -0,0 +1,117 @@
+import SphincsSecurity.Proof.Residual.RetainedResidualAccounting
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting ResidualByteAction
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs sourceInputs
+  signDigestLoop signAfterDigest
+set_option backward.isDefEq.respectTransparency false
+
+def CacheSizeBound (memory : Memory) : Prop :=
+  QueryCache.enncard memory.external.cache ≤ (memory.external.hashCalls : ENNReal)
+
+private theorem cacheFold_size (entries : List (HashInput × HashOutput)) (cache : ExternalCache) :
+    QueryCache.enncard (entries.foldl (fun (current : ExternalCache) entry => Function.update current entry.1 (some entry.2)) cache) ≤
+      QueryCache.enncard cache + (entries.length : ENNReal) := by
+  induction entries generalizing cache with
+  | nil => simp only [List.foldl_nil, List.length_nil, Nat.cast_zero, add_zero, le_refl]
+  | cons entry entries ih =>
+      refine (ih (Function.update cache entry.1 (some entry.2))).trans ?_
+      calc
+        _ ≤ (QueryCache.enncard cache + 1) + (entries.length : ENNReal) :=
+          add_le_add (QueryCache.enncard_cacheQuery_le cache entry.1 entry.2) le_rfl
+        _ = _ := by simp only [List.length_cons, Nat.cast_add, Nat.cast_one]; ac_rfl
+
+theorem CacheSizeBound.applyBoundary {memory : Memory} (hbound : CacheSizeBound memory) (trace : SigningBoundaryTrace) :
+    CacheSizeBound (memory.applyBoundary trace) := by
+  have hlength : (trace.messageCalls.length : ENNReal) ≤ trace.hashCalls := Nat.cast_le.mpr (List.length_filterMap_le _ _)
+  exact (cacheFold_size trace.messageCalls memory.external.cache).trans (by
+    change _ ≤ ((memory.external.hashCalls + trace.hashCalls : Nat) : ENNReal)
+    rw [Nat.cast_add]
+    exact add_le_add hbound hlength)
+
+variable (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+  (words : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem checkedHashResult_cacheSize (routing : Routing) (actual : Labels) (seed : inputs → HashOutput)
+    (input : inputs) (state : State inputs) (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) :
+    QueryCache.enncard (checkedHashResult key.parameter inputs hencoding words publicReplies selections rows routing actual seed input state).2.memory.external.cache ≤
+      QueryCache.enncard state.memory.external.cache + 1 := by
+  have hp := congrArg (fun result : Option HashOutput × ResidualByteFrontend.State inputs => QueryCache.enncard result.2.memory.cache)
+    (hashResult_project key.parameter inputs hencoding words publicReplies selections rows routing actual seed input state)
+  have hr := congrArg (fun result : Option HashOutput × ExternalMemory => QueryCache.enncard result.2.cache)
+    (ResidualByteFrontend.hashQueryResult_project key.parameter inputs words routing.disclosed routing.known
+      (freshPrefix key.parameter inputs hencoding words routing.disclosed routing.known publicReplies selections rows)
+      actual seed input (project state) hcovered
+      (freshPrefix_local key.parameter inputs hencoding words routing.disclosed routing.known publicReplies selections rows input))
+  change QueryCache.enncard (hashResult key.parameter inputs hencoding words publicReplies selections rows routing actual seed input state).2.memory.external.cache ≤ _
+  apply hp.trans_le
+  apply hr.trans_le
+  generalize ResidualByteFrontend.publicCachedReply inputs
+    (freshPrefix key.parameter inputs hencoding words routing.disclosed routing.known publicReplies selections rows)
+    actual seed input (project state).memory = answer
+  cases answer with
+  | none => exact le_self_add
+  | some answer => exact QueryCache.enncard_cacheQuery_le state.memory.external.cache input.val answer
+
+theorem lazyByteRun_world_cacheSizeBound (routing : Routing) (input : OracleWorld.Domain)
+    (hinputs : hashInputs (liftM (OracleWorld.query input)) ⊆ inputs) (state : State inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) (hbound : CacheSizeBound state.memory)
+    (result : Option (OracleWorld.Range input) × State inputs)
+    (hresult : lazyByteRun key.parameter inputs hencoding words publicReplies selections rows routing
+      (liftM (OracleWorld.query input)) state result ≠ 0) : CacheSizeBound result.2.memory := by
+  cases input with
+  | inl input =>
+      rw [← bind_pure (liftM (OracleWorld.query (.inl input))), lazyByteRun_random_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨answer, _, hresult⟩ := hresult
+      rw [lazyByteRun_pure] at hresult
+      simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact hbound
+  | inr input =>
+      have hin : input ∈ inputs := hinputs (by
+        rw [← bind_pure (liftM (OracleWorld.query (.inr input)))]
+        exact mem_hashInputs_hash_bind input pure)
+      obtain ⟨actual, seed, rfl⟩ := lazyByteRun_hash_result key.parameter inputs hencoding words publicReplies selections rows routing input hin state ha result hresult
+      unfold CacheSizeBound
+      rw [checkedHashResult_hashCalls, Nat.cast_add, Nat.cast_one]
+      exact (checkedHashResult_cacheSize key inputs hencoding words publicReplies selections rows routing actual seed ⟨input, hin⟩ state hcovered).trans
+        (add_le_add hbound le_rfl)
+
+variable (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+theorem monitoredStep_cacheSizeBound (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState inputs)
+    (hvalid : MonitoredValid inputs state) (hinputs : requestInputs key input ⊆ inputs)
+    (hbound : CacheSizeBound state.1.memory)
+    (result : Option ((OracleWorld + SigningSpec).Range input) × MonitoredState inputs)
+    (hresult : monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state result ≠ 0) :
+    CacheSizeBound result.2.1.memory := by
+  cases input with
+  | inl input =>
+      rw [monitoredStep, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨raw, hraw, hresult⟩ := hresult
+      simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      rw [lazyRun_externalProgram] at hraw
+      exact lazyByteRun_world_cacheSizeBound key inputs hencoding words publicReplies selections rows state.1.memory.routing
+        input hinputs state.1 hvalid.1 hvalid.2 hbound raw hraw
+  | inr message =>
+      rw [monitoredStep, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨annotation, _, hresult⟩ := hresult
+      rw [map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨raw, hraw, hresult⟩ := hresult
+      simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      have hin := digestInputs_of_request key inputs words selections message state.1.memory.routing.known hinputs
+      obtain ⟨record, hr, hm⟩ := lazyRun_jointSigningProgram_memory_trace key.parameter inputs hencoding words publicReplies selections rows
+        state.1.memory.routing key.root message (by simpa only [publicDigestLoop_eq] using hin) state.1 hvalid.1 hvalid.2 raw hraw
+      have heq : raw = (some record, raw.2) := Prod.ext hr rfl
+      rw [heq]
+      change CacheSizeBound raw.2.memory
+      rw [hm]
+      exact hbound.applyBoundary record.2
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCacheHistory.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCacheHistory.lean
new file mode 100644
index 000000000..dae90cba6
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCacheHistory.lean
@@ -0,0 +1,107 @@
+import SphincsSecurity.Proof.Residual.RetainedResidualCacheKernels
+import SphincsSecurity.Proof.Residual.RetainedResidualExceptionHistory
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec ENNReal CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs sourceInputs
+  certificateCacheExceptionWeight
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def cacheHistoryWeight {inputs : Finset HashInput} (key : SecretKey) (state : ExceptionHistoryState inputs) : ENNReal :=
+  if state.2.1 then 1 else certificateCacheExceptionWeight key state.1.1.memory.external.cache
+
+variable (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+  (words : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+  (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+theorem expected_exceptionHistoryStep_cacheWeight_le (input : (OracleWorld + SigningSpec).Domain) (state : ExceptionHistoryState inputs)
+    (hvalid : MonitoredValid inputs state.1) (hinputs : requestInputs key input ⊆ inputs) (hbound : CacheSizeBound state.1.1.memory) :
+    (∑' result, Pr[= result | exceptionHistoryStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+      cacheHistoryWeight key result.2) ≤ cacheHistoryWeight key state +
+        nativeMessageCharge key input (monitorView state.1) * certificateCacheExceptionRate := by
+  rw [exceptionHistoryStep, tsum_probOutput_map_mul]
+  cases hflag : state.2.1 with
+  | true =>
+      simp only [cacheHistoryWeight, exceptionHistoryUpdate, hflag, Bool.true_or, ite_true, mul_one]
+      exact tsum_probOutput_le_one.trans le_self_add
+  | false =>
+      conv_rhs => simp only [cacheHistoryWeight, hflag, Bool.false_eq_true, if_false]
+      by_cases hbefore : CertificateCacheExceptional key state.1.1.memory.external.cache
+      · simp only [cacheHistoryWeight, exceptionHistoryUpdate, hflag, Bool.false_or, decide_eq_true hbefore, Bool.true_or, ite_true, mul_one]
+        exact tsum_probOutput_le_one.trans ((certificateCacheExceptionWeight_bad key _ (Finite.of_enncard_le hbound) hbefore).trans le_self_add)
+      · apply le_trans ?_ (expected_monitoredStep_cacheWeight_le key inputs hencoding words publicReplies selections rows budget required stopAfter
+          input state.1 hvalid hinputs hbound)
+        apply ENNReal.tsum_le_tsum
+        intro result
+        by_cases hr : Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state.1] = 0
+        · simp only [hr, zero_mul, le_refl]
+        · rw [SPMF.probOutput_eq_apply] at hr
+          apply mul_le_mul' le_rfl
+          have hb := monitoredStep_cacheSizeBound key inputs hencoding words publicReplies selections rows budget required stopAfter
+            input state.1 hvalid hinputs hbound result hr
+          simp only [cacheHistoryWeight, exceptionHistoryUpdate, hflag, Bool.false_or, decide_eq_false hbefore, Bool.false_or, decide_eq_true_eq]
+          split
+          · exact certificateCacheExceptionWeight_bad key _ (Finite.of_enncard_le hb) (by assumption)
+          · exact le_rfl
+
+theorem expected_exceptionHistoryRun_cacheWeight_le {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : ExceptionHistoryState inputs) (hvalid : MonitoredValid inputs state.1)
+    (hinputs : sourceInputs key computation ⊆ inputs) (hbound : CacheSizeBound state.1.1.memory) :
+    (∑' result, Pr[= result | exceptionHistoryRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state] *
+      cacheHistoryWeight key result.2) ≤ cacheHistoryWeight key state +
+        expectedMonitoredPayment key inputs hencoding words publicReplies selections rows budget required stopAfter
+          (fun input current => nativeMessageCharge key input current * certificateCacheExceptionRate) computation state.1 := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [exceptionHistoryRun_pure, tsum_probOutput_pure_mul, expectedMonitoredPayment, construct_pure, add_zero, le_refl]
+  | query_bind input next ih =>
+      rw [exceptionHistoryRun_query_bind, tsum_probOutput_bind_mul]
+      let payment (result : Option ((OracleWorld + SigningSpec).Range input) × MonitoredState inputs) : ENNReal :=
+        result.1.elim 0 (fun answer => expectedMonitoredPayment key inputs hencoding words publicReplies selections rows budget required stopAfter
+          (fun input current => nativeMessageCharge key input current * certificateCacheExceptionRate) (next answer) result.2)
+      have herasure := congrArg (fun law : SPMF (Option ((OracleWorld + SigningSpec).Range input) × MonitoredState inputs) =>
+          ∑' result, Pr[= result | law] * payment result)
+        (exceptionHistoryStep_erasure key inputs hencoding words publicReplies selections rows budget required stopAfter input state)
+      rw [tsum_probOutput_map_mul] at herasure
+      calc
+        _ ≤ ∑' result, Pr[= result | exceptionHistoryStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+            (cacheHistoryWeight key result.2 + payment (result.1, result.2.1)) := by
+          apply ENNReal.tsum_le_tsum
+          intro result
+          by_cases hr : Pr[= result | exceptionHistoryStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] = 0
+          · simp only [hr, zero_mul, le_refl]
+          · rw [SPMF.probOutput_eq_apply] at hr
+            have hn := (exceptionHistoryStep_support key inputs hencoding words publicReplies selections rows budget required stopAfter input state result hr).1
+            have hv := monitoredStep_valid key inputs hencoding words publicReplies selections rows budget required stopAfter input state.1 hvalid _ hn
+            have hb := monitoredStep_cacheSizeBound key inputs hencoding words publicReplies selections rows budget required stopAfter
+              input state.1 hvalid ((requestInputs_subset key input next).trans hinputs) hbound _ hn
+            apply mul_le_mul' le_rfl
+            rcases result with ⟨answer, after⟩
+            cases answer with
+            | none => simp only [payment, Option.elim_none, tsum_probOutput_pure_mul, add_zero, le_refl]
+            | some answer => exact ih answer after hv ((sourceInputs_next_subset key input next answer).trans hinputs) hb
+        _ ≤ (cacheHistoryWeight key state + nativeMessageCharge key input (monitorView state.1) * certificateCacheExceptionRate) +
+            ∑' result, Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state.1] * payment result := by
+          simp only [mul_add, ENNReal.tsum_add]
+          rw [herasure]
+          exact add_le_add (expected_exceptionHistoryStep_cacheWeight_le key inputs hencoding words publicReplies selections rows budget required stopAfter
+            input state hvalid ((requestInputs_subset key input next).trans hinputs) hbound) le_rfl
+        _ = _ := by
+          change (cacheHistoryWeight key state + _) + _ = cacheHistoryWeight key state + (_ + _)
+          exact add_assoc _ _ _
+
+theorem exceptionHistoryRun_cache_le {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : ExceptionHistoryState inputs) (hvalid : MonitoredValid inputs state.1)
+    (hinputs : sourceInputs key computation ⊆ inputs) (hbound : CacheSizeBound state.1.1.memory) :
+    Pr[fun result => result.2.2.1 = true |
+      exceptionHistoryRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state] ≤
+      cacheHistoryWeight key state + expectedMonitoredPayment key inputs hencoding words publicReplies selections rows budget required stopAfter
+        (fun input current => nativeMessageCharge key input current * certificateCacheExceptionRate) computation state.1 := by
+  apply le_trans ?_ (expected_exceptionHistoryRun_cacheWeight_le key inputs hencoding words publicReplies selections rows budget required stopAfter
+    computation state hvalid hinputs hbound)
+  apply probEvent_le_tsum_probOutput_mul_cost_of_mem_support
+  intro result _ hflag
+  simp only [cacheHistoryWeight, hflag, ite_true, le_refl]
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCacheKernels.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCacheKernels.lean
new file mode 100644
index 000000000..9d8bdef9b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCacheKernels.lean
@@ -0,0 +1,193 @@
+import SphincsSecurity.Proof.Fts.CertificateCacheExceptionKernels
+import SphincsSecurity.Proof.Residual.RetainedResidualCacheAccounting
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec ENNReal CanonicalProbeRouting ResidualByteAction
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing SigningRecord)
+open FtsProbeSimulation (messageAnswers MessageHashInput messageHashCharge)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs sourceInputs
+  signDigestLoop certificateCacheExceptionWeight
+set_option backward.isDefEq.respectTransparency false
+
+variable (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+  (words : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem checkedHashResult_cache_subset (routing : Routing) (actual : Labels) (seed : inputs → HashOutput)
+    (input : inputs) (state : State inputs) (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) :
+    QueryCache.toSet state.memory.external.cache ⊆
+      QueryCache.toSet (checkedHashResult key.parameter inputs hencoding words publicReplies selections rows routing actual seed input state).2.memory.external.cache := by
+  rintro ⟨other, reply⟩ hreply
+  change state.memory.external.cache other = some reply at hreply
+  change (checkedHashResult key.parameter inputs hencoding words publicReplies selections rows routing actual seed input state).2.memory.external.cache other = some reply
+  by_cases hne : other ≠ input.val
+  · rw [checkedHashResult_cache_of_ne key.parameter inputs hencoding words publicReplies selections rows routing actual seed input state hcovered other hne]
+    exact hreply
+  · obtain rfl := not_ne_iff.mp hne
+    have hp := congrArg (fun result : Option HashOutput × ResidualByteFrontend.State inputs => result.2.memory.cache input.val)
+      (hashResult_project key.parameter inputs hencoding words publicReplies selections rows routing actual seed input state)
+    have hr := congrArg (fun result : Option HashOutput × ExternalMemory => result.2.cache input.val)
+      (ResidualByteFrontend.hashQueryResult_project key.parameter inputs words routing.disclosed routing.known
+        (freshPrefix key.parameter inputs hencoding words routing.disclosed routing.known publicReplies selections rows)
+        actual seed input (project state) hcovered
+        (freshPrefix_local key.parameter inputs hencoding words routing.disclosed routing.known publicReplies selections rows input))
+    change (hashResult key.parameter inputs hencoding words publicReplies selections rows routing actual seed input state).2.memory.external.cache input.val = _
+    apply hp.trans
+    apply hr.trans
+    simp only [ResidualByteFrontend.publicCachedReply, project, hreply, Option.elim_some,
+      ResidualByteFrontend.delivered, storeReply, Function.update_self]
+
+theorem expected_lazyWorld_cacheWeight_le (routing : Routing) (input : OracleWorld.Domain)
+    (state : State inputs) (hinputs : hashInputs (liftM (OracleWorld.query input)) ⊆ inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) (hbound : CacheSizeBound state.memory) :
+    (∑' result, Pr[= result | lazyByteRun key.parameter inputs hencoding words publicReplies selections rows routing
+        (liftM (OracleWorld.query input)) state] * certificateCacheExceptionWeight key result.2.memory.external.cache) ≤
+      certificateCacheExceptionWeight key state.memory.external.cache +
+        hashQueryCharge (fun cache hash => messageHashCharge key.parameter cache hash * certificateCacheExceptionRate) state.memory.external.cache input := by
+  by_cases hm : ∀ hash, input = .inr hash → MessageHashInput key.parameter hash
+  · have heq := congrArg (fun law : SPMF (Option (OracleWorld.Range input) × QueryCache HashSpec) =>
+        ∑' result, Pr[= result | law] * certificateCacheExceptionWeight key result.2)
+      (lazyByteRun_world_message_rom key.parameter inputs hencoding words publicReplies selections rows routing input hinputs hm state hcovered)
+    simp only [tsum_probOutput_map_mul, cacheResult, Prod.map_snd, id_eq] at heq
+    rw [heq]
+    exact expected_certificateCacheExceptionWeight_rom key input state.memory.external.cache (Finite.of_enncard_le hbound)
+  · cases input with
+    | inl sample => exact False.elim (hm (by intro hash heq; cases heq))
+    | inr input =>
+        have hmessage : ¬MessageHashInput key.parameter input := fun h => hm (by intro hash heq; cases heq; exact h)
+        have hin : input ∈ inputs := hinputs (by simpa only [bind_pure] using mem_hashInputs_hash_bind input pure)
+        simp only [hashQueryCharge, Sum.elim_inr, messageHashCharge, if_neg hmessage, zero_mul, add_zero]
+        calc
+          _ ≤ ∑' result, Pr[= result | lazyByteRun key.parameter inputs hencoding words publicReplies selections rows routing
+              (liftM (OracleWorld.query (.inr input))) state] * certificateCacheExceptionWeight key state.memory.external.cache := by
+            apply ENNReal.tsum_le_tsum
+            intro result
+            by_cases hs : lazyByteRun key.parameter inputs hencoding words publicReplies selections rows routing
+                (liftM (OracleWorld.query (.inr input))) state result = 0
+            · simp only [SPMF.probOutput_eq_apply, hs, zero_mul, le_refl]
+            · apply mul_le_mul' le_rfl
+              have hb := lazyByteRun_world_cacheSizeBound key inputs hencoding words publicReplies selections rows routing
+                (.inr input) hinputs state ha hcovered hbound result hs
+              apply certificateCacheExceptionWeight_messageAnswers_le key _ _ (Finite.of_enncard_le hb)
+                (lazyByteRun_hash_nonmessage key.parameter inputs hencoding words publicReplies selections rows routing
+                  input hin state ha hcovered hmessage result hs).symm
+              obtain ⟨actual, seed, rfl⟩ := lazyByteRun_hash_result key.parameter inputs hencoding words publicReplies selections rows routing
+                input hin state ha result hs
+              have hle := checkedHashResult_cache_subset key inputs hencoding words publicReplies selections rows routing actual seed ⟨input, hin⟩ state hcovered
+              unfold QueryCache.enncard
+              exact_mod_cast Set.encard_le_encard hle
+          _ ≤ _ := by
+            rw [ENNReal.tsum_mul_right]
+            exact mul_le_of_le_one_left' tsum_probOutput_le_one
+
+theorem expected_publicSigningWork_cacheWeight_le (known : Labels) (message : Message)
+    (cache : QueryCache HashSpec) (hfinite : Finite cache) :
+    (∑' result, Pr[= result | (simulateQ romImpl
+        (ResidualByteFrontend.publicSigningWork key.parameter key.root known words selections message)).run cache] *
+      certificateCacheExceptionWeight key result.2) ≤
+      certificateCacheExceptionWeight key cache + digestAttemptExpectation digestAttemptLimit key message cache * certificateCacheExceptionRate := by
+  rw [publicSigningWork_eq_digestWork, simulateQ_map, StateT.run_map, tsum_probOutput_map_mul,
+    publicDigestLoop_eq, simulateQ_boundaryComputation]
+  have h := expected_certificateCacheExceptionWeight_boundary key (signDigestLoop digestAttemptLimit key message) cache hfinite
+  have hc := (expectedBoundaryMessageCalls_eq_queryCharge key.parameter (signDigestLoop digestAttemptLimit key message) cache).trans
+    (expectedQueryCharge_signDigestLoop_message digestAttemptLimit key message cache)
+  change (∑' result, Pr[= result | boundaryRun key.parameter (signDigestLoop digestAttemptLimit key message) cache] *
+    (result.1.2.messageCalls.length : ENNReal)) = _ at hc
+  rw [hc] at h
+  exact h
+
+attribute [local irreducible] lazyRun environment ResidualByteFrontend.jointSigningProgram
+
+private theorem expected_evalDist {Result : Type} (computation : ProbComp Result) (weight : Result → ENNReal) :
+    (∑' result, Pr[= result | 𝒟[computation]] * weight result) =
+      ∑' result, Pr[= result | computation] * weight result := rfl
+
+private theorem expected_signing_cache_weight {inputs : Finset HashInput}
+    (native : SPMF (Option SigningRecord × State inputs)) (candidates : CanonicalCoordinate → Finset Digest)
+    (work : ProbComp ((PublicSigningRecord × Nat) × QueryCache HashSpec)) (bound : ENNReal)
+    (hwork : (∑' result, Pr[= result | work] * certificateCacheExceptionWeight key result.2) ≤ bound)
+    (hkernel : cacheResult <$> native =
+      (UniformTableCompletion.complete candidates >>= fun actual =>
+        (fun result => (some (completePublicSigningRecord (fun index tree leaf => actual (.ftsStart index tree leaf)) result.1.1), result.2)) <$>
+          𝒟[work])) :
+    (∑' result, Pr[= result | native] * certificateCacheExceptionWeight key result.2.memory.external.cache) ≤ bound := by
+  have heq := congrArg (fun law : SPMF (Option SigningRecord × QueryCache HashSpec) =>
+    ∑' result, Pr[= result | law] * certificateCacheExceptionWeight key result.2) hkernel
+  rw [tsum_probOutput_map_mul, tsum_probOutput_bind_mul] at heq
+  simp only [tsum_probOutput_map_mul, cacheResult, expected_evalDist] at heq
+  rw [heq]
+  calc
+    _ ≤ ∑' actual, Pr[= actual | UniformTableCompletion.complete candidates] * bound :=
+      ENNReal.tsum_le_tsum fun _ => mul_le_mul' le_rfl hwork
+    _ ≤ _ := by
+      rw [ENNReal.tsum_mul_right]
+      exact mul_le_of_le_one_left' tsum_probOutput_le_one
+
+theorem expected_lazySigning_cacheWeight_le (message : Message) (state : State inputs)
+    (hinputs : requestInputs key (.inr message) ⊆ inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) (hfinite : Finite state.memory.external.cache) :
+    (∑' result, Pr[= result | lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+        (simulateQ (embed inputs state.memory.routing)
+          (ResidualByteFrontend.jointSigningProgram inputs key.parameter key.root state.memory.routing.known words selections message)) state] *
+      certificateCacheExceptionWeight key result.2.memory.external.cache) ≤
+      certificateCacheExceptionWeight key state.memory.external.cache +
+        digestAttemptExpectation digestAttemptLimit key message state.memory.external.cache * certificateCacheExceptionRate := by
+  have hin := digestInputs_of_request key inputs words selections message state.memory.routing.known hinputs
+  exact expected_signing_cache_weight key _ state.candidates _ _
+    (expected_publicSigningWork_cacheWeight_le key words selections state.memory.routing.known message state.memory.external.cache hfinite)
+    (lazyRun_jointSigningProgram_cache key.parameter inputs hencoding words publicReplies selections rows state.memory.routing
+      key.root message (by simpa only [publicDigestLoop_eq] using hin) state ha hcovered)
+
+noncomputable def nativeMessageCharge (key : SecretKey) (input : (OracleWorld + SigningSpec).Domain)
+    (state : CertificateMonitorState) : ENNReal :=
+  match input with
+  | .inl world => hashQueryCharge (messageHashCharge key.parameter) state.1 world
+  | .inr message => digestAttemptExpectation digestAttemptLimit key message state.1
+
+variable (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+theorem monitoredSigningResult_cache (message : Message) (annotation : Nat × Index)
+    (state : MonitoredState inputs) (raw : Option SigningRecord × State inputs) :
+    (monitoredSigningResult key budget required stopAfter message annotation state raw).2.1.memory.external.cache =
+      raw.2.memory.external.cache := by
+  rcases raw with ⟨answer, after⟩
+  cases answer <;> rfl
+
+private theorem expected_signing_annotation_cacheWeight (message : Message) (state : MonitoredState inputs)
+    (native : SPMF (Option SigningRecord × State inputs)) (bound : ENNReal)
+    (hbound : (∑' result, Pr[= result | native] * certificateCacheExceptionWeight key result.2.memory.external.cache) ≤ bound) :
+    (∑' result, Pr[= result | ((liftM (signingAnnotation key budget message (monitorView state)) : SPMF _) >>= fun annotation =>
+      monitoredSigningResult key budget required stopAfter message annotation state <$> native)] *
+        certificateCacheExceptionWeight key result.2.1.memory.external.cache) ≤ bound := by
+  rw [tsum_probOutput_bind_mul]
+  simp only [tsum_probOutput_map_mul, monitoredSigningResult_cache]
+  calc
+    _ ≤ ∑' annotation, Pr[= annotation | (liftM (signingAnnotation key budget message (monitorView state)) : SPMF _)] * bound :=
+      ENNReal.tsum_le_tsum fun _ => mul_le_mul' le_rfl hbound
+    _ ≤ _ := by
+      rw [ENNReal.tsum_mul_right]
+      exact mul_le_of_le_one_left' tsum_probOutput_le_one
+
+theorem expected_monitoredStep_cacheWeight_le (input : (OracleWorld + SigningSpec).Domain)
+    (state : MonitoredState inputs) (hvalid : MonitoredValid inputs state)
+    (hinputs : requestInputs key input ⊆ inputs) (hbound : CacheSizeBound state.1.memory) :
+    (∑' result, Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+      certificateCacheExceptionWeight key result.2.1.memory.external.cache) ≤
+      certificateCacheExceptionWeight key state.1.memory.external.cache +
+        nativeMessageCharge key input (monitorView state) * certificateCacheExceptionRate := by
+  cases input with
+  | inl world =>
+      rw [monitoredStep, tsum_probOutput_map_mul, lazyRun_externalProgram]
+      have h := expected_lazyWorld_cacheWeight_le key inputs hencoding words publicReplies selections rows state.1.memory.routing
+        world state.1 hinputs hvalid.1 hvalid.2 hbound
+      cases world <;> simpa only [monitoredWorldResult, nativeMessageCharge, monitorView, hashQueryCharge, Sum.elim_inl,
+        Sum.elim_inr, zero_mul] using h
+  | inr message =>
+      exact expected_signing_annotation_cacheWeight key inputs budget required stopAfter message state _ _
+        (expected_lazySigning_cacheWeight_le key inputs hencoding words publicReplies selections rows
+          message state.1 hinputs hvalid.1 hvalid.2 (Finite.of_enncard_le hbound))
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCacheTail.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCacheTail.lean
new file mode 100644
index 000000000..510e1a245
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCacheTail.lean
@@ -0,0 +1,91 @@
+import SphincsSecurity.Proof.Residual.RetainedResidualCacheHistory
+import SphincsSecurity.Proof.Residual.RetainedResidualPaymentBudget
+import SphincsSecurity.Proof.Residual.RetainedResidualProposalTail
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec ENNReal CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs sourceInputs gameInputs
+  certificateCacheExceptionWeight
+set_option backward.isDefEq.respectTransparency false
+
+theorem exceptionHistoryRun_cache_le_budget (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (words : OtsReferenceWords)
+    (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+    (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : ExceptionHistoryState inputs) (hvalid : MonitoredValid inputs state.1)
+    (hinputs : sourceInputs key computation ⊆ inputs) (hbound : CacheSizeBound state.1.1.memory)
+    (q : Nat) (hq : ∀ result, monitoredRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state.1 result ≠ 0 →
+      result.2.1.memory.external.hashCalls ≤ q) :
+    Pr[fun result => result.2.2.1 = true |
+      exceptionHistoryRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state] ≤
+      cacheHistoryWeight key state + q * certificateCacheExceptionRate := by
+  apply le_trans (exceptionHistoryRun_cache_le key inputs hencoding words publicReplies selections rows budget required stopAfter
+    computation state hvalid hinputs hbound)
+  rw [expectedMonitoredPayment_mul]
+  exact add_le_add le_rfl (mul_le_mul' (expectedMonitoredPayment_le_budget key inputs hencoding words publicReplies selections rows budget required stopAfter
+    computation state.1 hvalid hinputs q hq) le_rfl)
+
+theorem initialExceptionHistorySource_cache_le (key : SecretKey) (adversary : Adversary)
+    (encoding : ReferenceEncodingAuxiliary) (dummy : OtsReferenceWords)
+    (exposed : InitialPublicLabels (referenceFamilyWords encoding.selections dummy)) (high : CanonicalGraphHighHalves)
+    (budget : Nat) (hparameter : key.parameter ∈ support sampleParameter)
+    (hencoding : encoding ∈ referenceEncodingAuxiliarySample.support)
+    (hroot : key.root = knownRoot (initialKnown (referenceFamilyWords encoding.selections dummy) exposed))
+    (hcost : HasHashQueryBound scheme adversary budget) :
+    Pr[fun result => result.2.2.1 = true | initialExceptionHistorySource key adversary encoding dummy exposed high budget] ≤
+      (budget : ENNReal) * (2 ^ 169 : ENNReal)⁻¹ := by
+  apply le_trans (exceptionHistoryRun_cache_le_budget key (gameInputs adversary)
+    (canonicalEncodingInputs_subset_retainedGameInputs adversary key.parameter)
+    (referenceFamilyWords encoding.selections dummy)
+    (coordinateGraphLabels (initialKnown (referenceFamilyWords encoding.selections dummy) exposed) high)
+    encoding.selections encoding.rows budget Finset.univ (proposalStop (fun _ _ _ _ => false))
+    (FtsProbeSimulation.unloggedRetainedRestComputation adversary ⟨key.root, key.parameter⟩)
+    ((initialState (gameInputs adversary) (referenceFamilyWords encoding.selections dummy) exposed,
+      initialCertificateMonitor 1212415 false), (false, false))
+    ⟨initialAllowed_nonempty _ exposed, initialState_rowsCovered _ _ exposed⟩
+    (sourceInputs_unlogged_subset_gameInputs adversary key)
+    (show CacheSizeBound (initialMemory (referenceFamilyWords encoding.selections dummy) exposed) from by
+      change QueryCache.enncard (∅ : QueryCache HashSpec) ≤ (1212415 : ENNReal)
+      rw [QueryCache.enncard_empty]
+      exact zero_le)
+    budget (initialMonitoredSource_hashCalls_le key adversary encoding dummy exposed high budget Finset.univ
+      (proposalStop (fun _ _ _ _ => false)) false hparameter hencoding hroot hcost))
+  change certificateCacheExceptionWeight key (∅ : QueryCache HashSpec) + (budget : ENNReal) * certificateCacheExceptionRate ≤ _
+  rw [certificateCacheExceptionWeight_initial key ∅ (fun _ _ => rfl), zero_add]
+  exact mul_le_mul' le_rfl certificateCacheExceptionRate_le
+
+theorem exceptionHistorySourceGame_cache_le (dummy : OtsReferenceWords) (adversary : Adversary) (budget : Nat)
+    (hcost : HasHashQueryBound scheme adversary budget) :
+    Pr[fun result => result.2.2.1 = true | exceptionHistorySourceGame dummy adversary budget] ≤
+      (budget : ENNReal) * (2 ^ 169 : ENNReal)⁻¹ := by
+  unfold exceptionHistorySourceGame
+  apply probEvent_bind_le_of_forall_le
+  intro parameter hparameter
+  have hp : parameter ∈ support sampleParameter := (mem_support_iff_evalDist_apply_ne_zero _ _).mpr hparameter
+  apply probEvent_bind_le_of_forall_le
+  intro encoding hencoding
+  have he : encoding ∈ referenceEncodingAuxiliarySample.support := by
+    simpa only [PMF.evalDist_eq, SPMF.support_eq_support, SPMF.support_liftM] using hencoding
+  apply probEvent_bind_le_of_forall_le
+  intro high _
+  apply probEvent_bind_le_of_forall_le
+  intro exposed _
+  unfold initialExceptionHistoryPrior
+  apply probEvent_bind_le_of_forall_le
+  intro labels _
+  exact initialExceptionHistorySource_cache_le _ adversary encoding dummy exposed high budget hp he rfl hcost
+
+theorem forgeAdvantage_le_native_bound (dummy : OtsReferenceWords)
+    (hdummy : ∀ lay tree leaf, TargetSum.Valid (dummy lay tree leaf)) (adversary : Adversary)
+    (budget : Nat) (hcost : HasHashQueryBound scheme adversary budget) (hbudget : budget ≤ 2 ^ 127) :
+    forgeAdvantage scheme adversary ≤
+      ENNReal.ofReal (2 * ((budget : ℝ) / 2 ^ digestBits) - ((budget : ℝ) / 2 ^ digestBits) ^ 2) +
+        (budget : ENNReal) * (11 / 2 ^ 144 : ENNReal) +
+        ((budget : ENNReal) * (2 ^ 169 : ENNReal)⁻¹ + (2 ^ 700 : ENNReal)⁻¹) :=
+  (forgeAdvantage_le_native_bound_add_cache_history dummy hdummy adversary budget hcost hbudget).trans
+    (add_le_add le_rfl (add_le_add (exceptionHistorySourceGame_cache_le dummy adversary budget hcost) le_rfl))
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCandidateHistory.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCandidateHistory.lean
new file mode 100644
index 000000000..78babad73
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCandidateHistory.lean
@@ -0,0 +1,39 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualSigningCandidates
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open ResidualByteFrontend (HiddenCandidateBound)
+attribute [local irreducible] hashInputs sourceInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+variable (key : SecretKey) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (words : OtsReferenceWords)
+  (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem lazyRun_request_hiddenCandidateBound (input : (OracleWorld + SigningSpec).Domain)
+    (hinputs : requestInputs key input ⊆ inputs) (state : State inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hbound : HiddenCandidateBound words state.memory.routing.disclosed (project state))
+    (result : Option ((OracleWorld + SigningSpec).Range input) × State inputs)
+    (hresult : lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+      (adversaryImpl inputs key.parameter key.root words selections input) state result ≠ 0) :
+    HiddenCandidateBound words result.2.memory.routing.disclosed (project result.2) := by
+  cases input with
+  | inl input =>
+      change lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+        (externalProgram inputs key.parameter words selections (liftM (OracleWorld.query input))) state result ≠ 0 at hresult
+      rw [lazyRun_externalProgram] at hresult
+      have hafter := lazyByteRun_hiddenCandidateBound key.parameter inputs hencoding words publicReplies selections rows
+        state.memory.routing _ hinputs state ha hbound result hresult
+      have hrouting := lazyRun_embed_routing key.parameter inputs hencoding words publicReplies selections rows
+        state.memory.routing _ state ha result hresult
+      rw [hrouting]
+      exact hafter
+  | inr message =>
+      exact lazyRun_signingProgram_hiddenCandidateBound inputs words publicReplies selections rows key hencoding message hinputs state
+        ha hcovered hbound result hresult
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCandidates.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCandidates.lean
new file mode 100644
index 000000000..7c3da30c8
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCandidates.lean
@@ -0,0 +1,95 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.ResidualByteCandidates
+import SphincsSecurity.Proof.Residual.RetainedResidualDigestLaw
+import SphincsSecurity.Proof.Residual.RetainedResidualInitial
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting ResidualByteAction
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing)
+open ResidualByteFrontend (HiddenCandidateBound)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+theorem initialState_hiddenCandidateBound (inputs : Finset HashInput) (words : OtsReferenceWords)
+    (exposed : InitialPublicLabels words) :
+    HiddenCandidateBound words (fun _ _ _ => False) (project (initialState inputs words exposed)) := by
+  intro coordinate hhidden
+  change 2 ^ digestBits ≤ (initialAllowed words exposed coordinate).card + 0
+  rw [initialAllowed_hidden words exposed coordinate hhidden, Finset.card_univ, Nat.add_zero]
+  exact le_of_eq (card_bitVec digestBits).symm
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+  (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem checkedHashResult_hiddenCandidateBound (routing : Routing) (actual : Labels) (seed : inputs → HashOutput)
+    (input : inputs) (state : State inputs)
+    (hbound : HiddenCandidateBound words routing.disclosed (project state)) :
+    HiddenCandidateBound words routing.disclosed
+      (project (checkedHashResult parameter inputs hencoding words publicReplies selections rows routing actual seed input state).2) := by
+  have h := ResidualByteFrontend.prefixHashQueryResult_hiddenCandidateBound parameter inputs words routing.disclosed
+    routing.known hencoding publicReplies selections rows actual seed input (project state) hbound
+  rw [← hashResult_project parameter inputs hencoding words publicReplies selections rows routing actual seed input state] at h
+  exact h
+
+theorem byteRun_hiddenCandidateBound {Result : Type} (routing : Routing) (actual : Labels) (seed : inputs → HashOutput)
+    (computation : OracleComp OracleWorld Result) (hinputs : hashInputs computation ⊆ inputs) (state : State inputs)
+    (hbound : HiddenCandidateBound words routing.disclosed (project state)) (result : Option Result × State inputs)
+    (hresult : byteRun parameter inputs hencoding words publicReplies selections rows routing actual seed computation state result ≠ 0) :
+    HiddenCandidateBound words routing.disclosed (project result.2) := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      simp only [byteRun_pure, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact hbound
+  | query_bind input next ih =>
+      have hnext : ∀ answer, hashInputs (next answer) ⊆ inputs :=
+        fun answer => (hashInputs_next_subset input next answer).trans hinputs
+      cases input with
+      | inl input =>
+          rw [byteRun_random_bind] at hresult
+          obtain ⟨answer, _, hresult⟩ := (RetainedObservation.bind_nonzero _ _ _).mp hresult
+          exact ih answer (hnext answer) state hbound result hresult
+      | inr input =>
+          have hin : input ∈ inputs := hinputs (mem_hashInputs_hash_bind input next)
+          rw [byteRun_hash_bind parameter inputs hencoding words publicReplies selections rows routing actual seed input hin] at hresult
+          have hafter := checkedHashResult_hiddenCandidateBound parameter inputs hencoding words publicReplies selections rows
+            routing actual seed ⟨input, hin⟩ state hbound
+          generalize hstep : checkedHashResult parameter inputs hencoding words publicReplies selections rows routing actual seed
+            ⟨input, hin⟩ state = step at hresult hafter
+          rcases step with ⟨answer, after⟩
+          cases answer with
+          | none =>
+              simp only [Option.elim_none, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+              subst result
+              exact hafter
+          | some answer => exact ih answer (hnext answer) after hafter result hresult
+
+theorem lazyByteRun_hiddenCandidateBound {Result : Type} (routing : Routing)
+    (computation : OracleComp OracleWorld Result) (hinputs : hashInputs computation ⊆ inputs) (state : State inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hbound : HiddenCandidateBound words routing.disclosed (project state)) (result : Option Result × State inputs)
+    (hresult : lazyByteRun parameter inputs hencoding words publicReplies selections rows routing computation state result ≠ 0) :
+    HiddenCandidateBound words routing.disclosed (project result.2) := by
+  unfold lazyByteRun at hresult
+  rw [← run_erasure _ _ state ha, RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨actual, _, hresult⟩ := hresult
+  rw [RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨seed, _, hresult⟩ := hresult
+  exact byteRun_hiddenCandidateBound parameter inputs hencoding words publicReplies selections rows routing actual seed
+    computation hinputs state hbound result hresult
+
+theorem lazyRun_embed_project {Result : Type} (routing : Routing)
+    (computation : OracleComp (ResidualByteFrontend.World inputs) Result) (state : State inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty) :
+    projectResult <$> lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+      (simulateQ (embed inputs routing) computation) state =
+      lazyRun (ResidualByteFrontend.prefixEnvironment parameter inputs hencoding words routing.disclosed routing.known
+        publicReplies selections rows) computation (project state) := by
+  rw [← run_erasure _ _ state ha, ← run_erasure _ _ (project state) ha]
+  simp only [map_bind, observedRun_embed parameter inputs hencoding words publicReplies selections rows routing]
+  rfl
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCertificateTransfer.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCertificateTransfer.lean
new file mode 100644
index 000000000..776a65f4d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCertificateTransfer.lean
@@ -0,0 +1,138 @@
+import SphincsSecurity.Proof.Residual.RetainedResidualBankCompleteness
+import SphincsSecurity.Proof.Residual.RetainedResidualStrongCoverage
+import SphincsSecurity.Proof.Residual.RetainedResidualPrimitivePotential
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs sourceInputs
+  signDigestLoop signAfterDigest gameInputs
+set_option backward.isDefEq.respectTransparency false
+
+theorem initialMonitoredSource_strong_certificate (key : SecretKey) (adversary : Adversary)
+    (encoding : ReferenceEncodingAuxiliary) (hencoding : encoding ∈ referenceEncodingAuxiliarySample.support)
+    (dummy : OtsReferenceWords) (hdummy : ∀ lay tree leaf, TargetSum.Valid (dummy lay tree leaf))
+    (exposed : InitialPublicLabels (referenceFamilyWords encoding.selections dummy)) (high : CanonicalGraphHighHalves)
+    (hroot : key.root = knownRoot (initialKnown (referenceFamilyWords encoding.selections dummy) exposed))
+    (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule) (stopped : Bool)
+    (forgery : Forgery) (after : MonitoredState (gameInputs adversary))
+    (hresult : initialMonitoredSource key adversary encoding dummy exposed high budget required stopAfter stopped
+      (some (forgery, true), after) ≠ 0)
+    (hnew : ¬ SigningTranscript.Contains after.1.memory.log forgery) :
+    TargetCertificateAt key Finset.univ (after.1.memory.external.cache, after.1.memory.log)
+      (signingInput key forgery.message forgery.signature) := by
+  have h := map_nonzero _ (fun result => (result.1, result.2.1)) (some (forgery, true), after) hresult
+  rw [initialMonitoredSource, monitoredRun_erasure, hroot] at h
+  rw [← run_erasure _ _ (initialState (gameInputs adversary) (referenceFamilyWords encoding.selections dummy) exposed)
+    (initialAllowed_nonempty _ exposed), RetainedObservation.bind_nonzero] at h
+  obtain ⟨labels, hlabels, h⟩ := h
+  rw [initialState_completion] at hlabels
+  rw [RetainedObservation.bind_nonzero] at h
+  obtain ⟨seed, _, h⟩ := h
+  let auxiliary : ReferenceAuxiliary (gameInputs adversary) := ⟨encoding.selections, encoding.rows, seed⟩
+  have hauxiliary := referenceEncodingAuxiliary_support_seed (gameInputs adversary) encoding hencoding seed
+  let context := initialContext key.parameter (gameInputs adversary)
+    (canonicalEncodingInputs_subset_retainedGameInputs adversary key.parameter) auxiliary hauxiliary dummy exposed high labels
+  have hrootContext : context.key.root = canonicalGraphRoot context.graph :=
+    initialKnown_root (referenceFamilyWords encoding.selections dummy) exposed labels hlabels high
+  have hcompatible : Compatible context (initialState (gameInputs adversary) (referenceFamilyWords encoding.selections dummy) exposed).memory := by
+    refine ⟨?_, ?_, ?_, ?_, ?_⟩
+    · simpa only [context, auxiliary, Context.words, Context.actual, initialContext, coordinateGraphLabels_value,
+        initialState, initialMemory] using initialKnown_agrees (referenceFamilyWords encoding.selections dummy) exposed labels hlabels
+    · exact initialKnown_graphReplies (referenceFamilyWords encoding.selections dummy) exposed labels hlabels high
+    · intro input answer hanswer; cases hanswer
+    · intro input answer hanswer; cases hanswer
+    · intro input answer hanswer; cases hanswer
+  have hrun : observedRun context.environment context.actual context.auxiliary.seed
+      (simulateQ (adversaryImpl (gameInputs adversary) context.key.parameter context.key.root context.words context.auxiliary.selections)
+        (FtsProbeSimulation.unloggedRetainedRestComputation adversary ⟨context.key.root, context.key.parameter⟩))
+      (initialState (gameInputs adversary) (referenceFamilyWords encoding.selections dummy) exposed)
+      (some (forgery, true), after.1) ≠ 0 := by
+    simpa only [context, auxiliary, Context.environment, Context.actual, Context.words, initialContext, coordinateGraphLabels_value] using h
+  have hcertificate := observedRun_rest_certificate context adversary (sourceInputs_unlogged_subset_gameInputs adversary context.key)
+    (initialState (gameInputs adversary) (referenceFamilyWords encoding.selections dummy) exposed) (initialState_rowsCovered _ _ exposed)
+    hcompatible (signingHistory_initial context.key context.oracle _ exposed) hdummy hrootContext forgery after.1 hrun hnew
+  have hparameter : context.key.parameter = key.parameter := rfl
+  have hpublicRoot : context.key.root = key.root := hroot.symm
+  simpa only [TargetCertificateAt, TargetCoveredOn, signingInput, hparameter, hpublicRoot] using hcertificate
+
+theorem initialMonitoredSource_strong_count (key : SecretKey) (adversary : Adversary)
+    (encoding : ReferenceEncodingAuxiliary) (hencoding : encoding ∈ referenceEncodingAuxiliarySample.support)
+    (dummy : OtsReferenceWords) (hdummy : ∀ lay tree leaf, TargetSum.Valid (dummy lay tree leaf))
+    (exposed : InitialPublicLabels (referenceFamilyWords encoding.selections dummy)) (high : CanonicalGraphHighHalves)
+    (hroot : key.root = knownRoot (initialKnown (referenceFamilyWords encoding.selections dummy) exposed))
+    (budget : Nat) (stopAfter : CertificateStopRule) (stopped : Bool)
+    (forgery : Forgery) (after : MonitoredState (gameInputs adversary))
+    (hresult : initialMonitoredSource key adversary encoding dummy exposed high budget Finset.univ stopAfter stopped
+      (some (forgery, true), after) ≠ 0)
+    (hnew : ¬ SigningTranscript.Contains after.1.memory.log forgery) (halive : after.2.stopped = false) :
+    1 ≤ certificateBankCount after.2.bank := by
+  apply initialMonitoredSource_certificate_count key budget Finset.univ stopAfter adversary encoding dummy exposed high stopped
+    (some (forgery, true), after) hresult halive (signingInput key forgery.message forgery.signature)
+  exact initialMonitoredSource_strong_certificate key adversary encoding hencoding dummy hdummy exposed high hroot budget
+    Finset.univ stopAfter stopped forgery after hresult hnew
+
+def MonitoredStrongWin {inputs : Finset HashInput} (result : Option (Forgery × Bool) × MonitoredState inputs) : Prop :=
+  ∃ value, result.1 = some value ∧ sourceVerdict value result.2.1.memory.log = true
+
+def MonitoredStrongException {inputs : Finset HashInput} (result : Option (Forgery × Bool) × MonitoredState inputs) : Prop :=
+  MonitoredStrongWin result ∧ result.2.2.stopped = true
+
+theorem initialMonitoredSource_strong_le_count_add_exception (key : SecretKey) (adversary : Adversary)
+    (encoding : ReferenceEncodingAuxiliary) (hencoding : encoding ∈ referenceEncodingAuxiliarySample.support)
+    (dummy : OtsReferenceWords) (hdummy : ∀ lay tree leaf, TargetSum.Valid (dummy lay tree leaf))
+    (exposed : InitialPublicLabels (referenceFamilyWords encoding.selections dummy)) (high : CanonicalGraphHighHalves)
+    (hroot : key.root = knownRoot (initialKnown (referenceFamilyWords encoding.selections dummy) exposed))
+    (budget : Nat) (stopAfter : CertificateStopRule) (stopped : Bool) :
+    Pr[MonitoredStrongWin | initialMonitoredSource key adversary encoding dummy exposed high budget Finset.univ stopAfter stopped] ≤
+      (∑' result, Pr[= result | initialMonitoredSource key adversary encoding dummy exposed high budget Finset.univ stopAfter stopped] *
+        certificateBankCount result.2.2.bank) +
+      Pr[MonitoredStrongException | initialMonitoredSource key adversary encoding dummy exposed high budget Finset.univ stopAfter stopped] := by
+  let law := initialMonitoredSource key adversary encoding dummy exposed high budget Finset.univ stopAfter stopped
+  have hcount : Pr[fun result => MonitoredStrongWin result ∧ result.2.2.stopped = false | law] ≤
+      ∑' result, Pr[= result | law] * certificateBankCount result.2.2.bank := by
+    apply probEvent_le_tsum_probOutput_mul_cost_of_mem_support
+    rintro ⟨answer, after⟩ hsupport ⟨⟨⟨forgery, checked⟩, hanswer, hwin⟩, halive⟩
+    simp only [sourceVerdict, Bool.and_eq_true, decide_eq_true_eq] at hwin
+    obtain ⟨⟨_, hnew⟩, rfl⟩ := hwin
+    dsimp only at hanswer halive hnew ⊢
+    subst answer
+    have hresult := probOutput_ne_zero_of_mem_support hsupport
+    rw [SPMF.probOutput_eq_apply] at hresult
+    exact initialMonitoredSource_strong_count key adversary encoding hencoding dummy hdummy exposed high hroot
+      budget stopAfter stopped forgery after hresult hnew halive
+  have hsplit : Pr[MonitoredStrongWin | law] ≤
+      Pr[fun result => MonitoredStrongWin result ∧ result.2.2.stopped = false | law] + Pr[MonitoredStrongException | law] := by
+    apply le_trans ?_ (probEvent_or_le law _ _)
+    apply probEvent_mono
+    intro result _ hwin
+    cases hstop : result.2.2.stopped with
+    | false => exact Or.inl ⟨hwin, rfl⟩
+    | true => exact Or.inr ⟨hwin, hstop⟩
+  exact hsplit.trans (add_le_add hcount le_rfl)
+
+theorem initialMonitoredSource_stop_add_strong_le (key : SecretKey) (adversary : Adversary)
+    (encoding : ReferenceEncodingAuxiliary) (dummy : OtsReferenceWords)
+    (hdummy : ∀ lay tree leaf, TargetSum.Valid (dummy lay tree leaf))
+    (exposed : InitialPublicLabels (referenceFamilyWords encoding.selections dummy)) (high : CanonicalGraphHighHalves)
+    (budget : Nat) (stopAfter : CertificateStopRule) (stopped : Bool)
+    (hparameter : key.parameter ∈ support sampleParameter)
+    (hencoding : encoding ∈ referenceEncodingAuxiliarySample.support)
+    (hroot : key.root = knownRoot (initialKnown (referenceFamilyWords encoding.selections dummy) exposed))
+    (hcost : HasHashQueryBound scheme adversary budget) (hbudget : budget ≤ 2 ^ 127) :
+    Pr[fun result => result.1 = none |
+      initialMonitoredSource key adversary encoding dummy exposed high budget Finset.univ (proposalStop stopAfter) stopped] +
+      Pr[MonitoredStrongWin |
+        initialMonitoredSource key adversary encoding dummy exposed high budget Finset.univ (proposalStop stopAfter) stopped] ≤
+      ENNReal.ofReal (2 * ((budget : ℝ) / 2 ^ digestBits) - ((budget : ℝ) / 2 ^ digestBits) ^ 2) +
+        (budget : ENNReal) * (11 / 2 ^ 144 : ENNReal) +
+        Pr[MonitoredStrongException |
+          initialMonitoredSource key adversary encoding dummy exposed high budget Finset.univ (proposalStop stopAfter) stopped] := by
+  have hwin := initialMonitoredSource_strong_le_count_add_exception key adversary encoding hencoding dummy hdummy exposed high hroot
+    budget (proposalStop stopAfter) stopped
+  have hbound := initialMonitoredSource_primitive_add_full_count_le key adversary encoding dummy exposed high budget stopAfter stopped
+    hparameter hencoding hroot hcost hbudget
+  exact (add_le_add le_rfl hwin).trans (by rw [← add_assoc]; exact add_le_add hbound le_rfl)
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCheckedTrace.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCheckedTrace.lean
new file mode 100644
index 000000000..ca0023697
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCheckedTrace.lean
@@ -0,0 +1,108 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualHashTrace
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting ResidualByteAction
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs
+set_option backward.isDefEq.respectTransparency false
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+  (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem hashResult_project (routing : Routing) (actual : Labels) (seed : inputs → HashOutput) (input : inputs) (state : State inputs) :
+    projectResult (hashResult parameter inputs hencoding words publicReplies selections rows routing actual seed input state) =
+      ResidualByteFrontend.hashQueryResult parameter inputs words routing.disclosed routing.known
+        (freshPrefix parameter inputs hencoding words routing.disclosed routing.known publicReplies selections rows)
+        actual seed input (project state) := by
+  have h := observedRun_embed parameter inputs hencoding words publicReplies selections rows routing actual seed
+    (ResidualByteFrontend.hashQuery input) state
+  rw [observedRun_hashQuery, ResidualByteFrontend.observedRun_hashQuery, map_pure] at h
+  have h := congrArg SPMF.support h
+  simpa only [SPMF.support_pure, Set.singleton_eq_singleton_iff] using h
+
+theorem observedRun_stop (routing : Routing) (actual : Labels) (seed : inputs → HashOutput) (state : State inputs) :
+    observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+      (embed inputs routing (.inl .stop)) state = pure (none, state) := by
+  simp only [embed, observedRun, runWith, simulateQ_spec_query, observedImpl, environment,
+    ResidualByteFrontend.environment, OptionT.run_mk, StateT.run_mk, PMF.pure_map, SPMF.lift_pure, pure_bind, afterControl, project]
+
+noncomputable def checkedHashResult (routing : Routing) (actual : Labels) (seed : inputs → HashOutput) (input : inputs) (state : State inputs) :
+    Option HashOutput × State inputs :=
+  ResidualByteFrontend.checkedResult (PublicEncodingMatch.Match parameter (knownEncodingMessage routing.known) words selections)
+    input.val (hashResult parameter inputs hencoding words publicReplies selections rows routing actual seed input state)
+
+theorem observedRun_checkedHashQuery (routing : Routing) (actual : Labels) (seed : inputs → HashOutput) (input : inputs) (state : State inputs) :
+    observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+      (simulateQ (embed inputs routing) (ResidualByteFrontend.checkedHashQuery
+        (PublicEncodingMatch.Match parameter (knownEncodingMessage routing.known) words selections) input)) state =
+      pure (checkedHashResult parameter inputs hencoding words publicReplies selections rows routing actual seed input state) := by
+  rw [ResidualByteFrontend.checkedHashQuery, simulateQ_bind, observedRun_bind, observedRun_hashQuery, pure_bind]
+  unfold checkedHashResult
+  generalize hresult : hashResult parameter inputs hencoding words publicReplies selections rows routing actual seed input state = result
+  rcases result with ⟨answer, after⟩
+  cases answer with
+  | none => rfl
+  | some answer =>
+      change _ = pure (ResidualByteFrontend.checkedResult _ input.val (some answer, after))
+      dsimp only [Option.elim_some, ResidualByteFrontend.checkedResult, Option.bind_some]
+      split
+      · rw [simulateQ_spec_query, observedRun_stop]
+      · rw [simulateQ_pure, observedRun, runWith_pure]
+
+theorem checkedHashResult_memory (routing : Routing) (actual : Labels) (seed : inputs → HashOutput) (input : inputs) (state : State inputs) :
+    let result := checkedHashResult parameter inputs hencoding words publicReplies selections rows routing actual seed input state
+    result.2.memory = state.memory.afterReply parameter input.val result.1 result.2.memory.external := by
+  have h := hashResult_memory parameter inputs hencoding words publicReplies selections rows routing actual seed input state
+  dsimp only at h ⊢
+  unfold checkedHashResult
+  generalize hresult : hashResult parameter inputs hencoding words publicReplies selections rows routing actual seed input state = result at *
+  rcases result with ⟨answer, after⟩
+  cases answer with
+  | none => exact h
+  | some answer =>
+      simp only [ResidualByteFrontend.checkedResult, Option.bind_some]
+      split
+      · rename_i hmatch
+        have hnot : ¬FtsProbeSimulation.MessageHashInput parameter input.val := by
+          intro hmessage
+          obtain ⟨position, hat, _⟩ := hmatch
+          exact ResidualByteFrontend.message_not_encoding parameter input.val hmessage position hat
+        simpa only [Memory.afterReply, Option.elim_some, Option.elim_none, Memory.observeMessage, if_neg hnot] using h
+      · exact h
+
+noncomputable def fixedHashStep (routing : Routing) (actual : Labels) (oracle : QueryImpl HashSpec Id) (input : HashInput) (memory : Memory) :
+    Option HashOutput × Memory :=
+  let result := ResidualByteFrontend.checkedResult (PublicEncodingMatch.Match parameter (knownEncodingMessage routing.known) words selections)
+    input (ResidualByteFrontend.fixedStep parameter words routing.disclosed routing.known actual oracle input memory.external)
+  (result.1, memory.afterReply parameter input result.1 result.2)
+
+theorem checkedHashResult_eq_fixed (routing : Routing) (actual : Labels) (seed : inputs → HashOutput)
+    (oracle : QueryImpl HashSpec Id) (input : inputs) (state : State inputs)
+    (hfresh : ResidualByteAction.eval actual seed
+      (freshPrefix parameter inputs hencoding words routing.disclosed routing.known publicReplies selections rows input) =
+      ResidualByteFrontend.fixedAnswer parameter words routing.disclosed actual oracle input.val)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hmatches : ResidualByteFrontend.CacheMatches oracle state.memory.external.cache)
+    (hclean : CacheClean parameter words routing.disclosed actual state.memory.external.cache) :
+    let result := checkedHashResult parameter inputs hencoding words publicReplies selections rows routing actual seed input state
+    (result.1, result.2.memory) = fixedHashStep parameter words selections routing actual oracle input.val state.memory := by
+  have hproject := congrArg (fun result : Option HashOutput × ResidualByteFrontend.State inputs => (result.1, result.2.memory))
+    (hashResult_project parameter inputs hencoding words publicReplies selections rows routing actual seed input state)
+  have hfixed := ResidualByteFrontend.hashQueryResult_eq_fixed parameter inputs words routing.disclosed routing.known
+    (freshPrefix parameter inputs hencoding words routing.disclosed routing.known publicReplies selections rows)
+    actual seed oracle input (project state) hcovered
+    (freshPrefix_local parameter inputs hencoding words routing.disclosed routing.known publicReplies selections rows input) hmatches hclean hfresh
+  dsimp only [projectResult, project] at hproject
+  have h := congrArg (ResidualByteFrontend.checkedResult
+    (PublicEncodingMatch.Match parameter (knownEncodingMessage routing.known) words selections) input.val) (hproject.trans hfixed)
+  change ((checkedHashResult parameter inputs hencoding words publicReplies selections rows routing actual seed input state).1,
+    (checkedHashResult parameter inputs hencoding words publicReplies selections rows routing actual seed input state).2.memory.external) = _ at h
+  dsimp only
+  rw [checkedHashResult_memory]
+  exact congrArg (fun result => (result.1, state.memory.afterReply parameter input.val result.1 result.2)) h
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCompletion.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCompletion.lean
new file mode 100644
index 000000000..3262d5049
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCompletion.lean
@@ -0,0 +1,117 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.ResidualSigningDisclosure
+import SphincsSecurity.Proof.Residual.RetainedResidualMessageTrace
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing SigningRecord)
+set_option backward.isDefEq.respectTransparency false
+
+def Memory.accountWork (memory : Memory) (cost : Nat) : Memory :=
+  { memory with external := ResidualByteFrontend.accountWork memory.external cost }
+
+theorem applyBoundary_pow_none (memory : Memory) (cost : Nat) :
+    memory.applyBoundary ((FreeMonoid.of none : SigningBoundaryTrace) ^ cost) = memory.accountWork cost := by
+  simp only [Memory.applyBoundary, ResidualByteFrontend.applyBoundary_pow_none, SigningBoundaryTrace.messageCalls_pow_none,
+    List.append_nil, Memory.accountWork]
+
+theorem publicSigningWork_fixed_memory (parameter : PublicParameter) (root : Digest) (oracle : QueryImpl HashSpec Id)
+    (known : Labels) (words : OtsReferenceWords) (selections : ReferenceFamily) (message : Message) (memory : Memory) :
+    (fun result => (result.1.1, (memory.applyBoundary result.2).accountWork result.1.2)) <$>
+        fixedBoundaryRun parameter oracle (ResidualByteFrontend.publicSigningWork parameter root known words selections message) =
+      (fun record => (record, memory.applyBoundary record.2)) <$>
+        publicSigningRecord parameter root oracle known words selections message := by
+  rw [ResidualByteFrontend.publicSigningWork, fixedBoundaryRun_bind, ResidualByteFrontend.fixedBoundaryRun_boundaryComputation,
+    publicSigningRecord, map_bind, bind_map_left, map_bind]
+  apply bind_congr
+  rintro ⟨selected, trace⟩
+  cases selected with
+  | none => simp only [fixedBoundaryRun_pure, map_pure, mul_one]; rfl
+  | some selected =>
+      simp only [fixedBoundaryRun_pure, map_pure, mul_one]
+      rw [applyBoundary_mul, applyBoundary_pow_none]
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+  (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+noncomputable def disclosureSequenceState (actual : Labels) {n : Nat} (coordinates : Fin n → CanonicalCoordinate) (state : State inputs) : State inputs :=
+  (List.ofFn coordinates).foldl (fun state coordinate =>
+    disclosedState (environment parameter inputs hencoding words publicReplies selections rows) state coordinate (actual coordinate)) state
+
+theorem observedRun_disclosureSequence_bind {Result : Type} (routing : Routing) (actual : Labels) (seed : inputs → HashOutput)
+    {n : Nat} (coordinates : Fin n → CanonicalCoordinate) (next : (Fin n → Digest) → OracleComp (World inputs) Result) (state : State inputs) :
+    observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+      (simulateQ (embed inputs routing) (sequenceFin fun index => ResidualByteFrontend.jointDisclosure (coordinates index)) >>= next) state =
+      observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+        (next (fun index => actual (coordinates index)))
+        (disclosureSequenceState parameter inputs hencoding words publicReplies selections rows actual coordinates state) := by
+  induction n generalizing state with
+  | zero =>
+      have hvalues : (Fin.elim0 : Fin 0 → Digest) = (fun index => actual (coordinates index)) := by
+        funext index
+        exact Fin.elim0 index
+      simp only [sequenceFin, simulateQ_pure, pure_bind, hvalues, disclosureSequenceState, List.ofFn_zero, List.foldl_nil]
+  | succ n ih =>
+      rw [sequenceFin, simulateQ_bind, bind_assoc]
+      simp only [ResidualByteFrontend.jointDisclosure, simulateQ_spec_query, embed]
+      rw [observedRun, runWith_query_bind]
+      simp only [observedImpl, OptionT.run_mk, StateT.run_mk, pure_bind, simulateQ_bind, simulateQ_pure, bind_assoc]
+      change observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+        (simulateQ (embed inputs routing) (sequenceFin fun index => ResidualByteFrontend.jointDisclosure (coordinates index.succ)) >>=
+          fun tail => next (Fin.cons (actual (coordinates 0)) tail))
+        (disclosedState (environment parameter inputs hencoding words publicReplies selections rows) state (coordinates 0) (actual (coordinates 0))) = _
+      rw [ih]
+      have hvalues : Fin.cons (actual (coordinates 0)) (fun index => actual (coordinates index.succ)) =
+          (fun index => actual (coordinates index)) := by
+        funext index
+        cases index using Fin.cases <;> rfl
+      rw [hvalues]
+      simp only [disclosureSequenceState, List.ofFn_succ, List.foldl_cons]
+
+theorem disclosureSequenceState_memory (actual : Labels) {n : Nat} (coordinates : Fin n → CanonicalCoordinate) (state : State inputs) :
+    (disclosureSequenceState parameter inputs hencoding words publicReplies selections rows actual coordinates state).memory = state.memory := by
+  induction n generalizing state with
+  | zero => rfl
+  | succ n ih =>
+      rw [disclosureSequenceState, List.ofFn_succ, List.foldl_cons]
+      change (disclosureSequenceState parameter inputs hencoding words publicReplies selections rows actual
+        (fun index => coordinates index.succ)
+        (disclosedState (environment parameter inputs hencoding words publicReplies selections rows) state (coordinates 0) (actual (coordinates 0)))).memory = _
+      rw [ih]
+      rfl
+
+theorem observedRun_completeRecord_memory (routing : Routing) (actual : Labels) (seed : inputs → HashOutput)
+    (record : PublicSigningRecord) (state : State inputs) :
+    forgetState <$> observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+      (simulateQ (embed inputs routing) (ResidualByteFrontend.jointCompleteSigningRecord record)) state =
+      pure (some (completePublicSigningRecord (fun index tree leaf => actual (.ftsStart index tree leaf)) record), state.memory) := by
+  rcases record with ⟨⟨plan, view⟩, trace⟩
+  cases plan <;> cases view <;> simp only [ResidualByteFrontend.jointCompleteSigningRecord, completePublicSigningRecord,
+    Option.map_none, Option.map_some, simulateQ_pure]
+  all_goals try (solve | simp only [observedRun, runWith_pure, map_pure, forgetState])
+  rw [simulateQ_bind]
+  simp only [simulateQ_pure]
+  rw [observedRun_disclosureSequence_bind]
+  simp only [observedRun, runWith_pure, map_pure, forgetState, disclosureSequenceState_memory]
+
+theorem observedRun_account_bind {Result : Type} (routing : Routing) (actual : Labels) (seed : inputs → HashOutput)
+    (cost : Nat) (next : Unit → OracleComp (World inputs) Result) (state : State inputs) :
+    observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+      (embed inputs routing (.inl (.account cost)) >>= next) state =
+      observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+        (next ()) { state with memory := state.memory.accountWork cost } := by
+  rw [embed, observedRun, runWith_query_bind]
+  simp only [observedImpl, environment, ResidualByteFrontend.environment, OptionT.run_mk, StateT.run_mk,
+    PMF.pure_map, SPMF.lift_pure, pure_bind, Option.elim_some, observedRun, afterControl, project,
+    Memory.accountWork, ResidualByteFrontend.accountWork]
+
+theorem observedRun_completeWork_memory (routing : Routing) (actual : Labels) (seed : inputs → HashOutput)
+    (work : PublicSigningRecord × Nat) (state : State inputs) :
+    forgetState <$> observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+      (simulateQ (embed inputs routing) (ResidualByteFrontend.jointCompleteSigningWork work)) state =
+      pure (some (completePublicSigningRecord (fun index tree leaf => actual (.ftsStart index tree leaf)) work.1), state.memory.accountWork work.2) := by
+  rw [ResidualByteFrontend.jointCompleteSigningWork, simulateQ_bind, simulateQ_spec_query, observedRun_account_bind, observedRun_completeRecord_memory]
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualComposition.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualComposition.lean
new file mode 100644
index 000000000..8cae7e67c
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualComposition.lean
@@ -0,0 +1,54 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualSource
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs sourceInputs canonicalEncodingInputs canonicalGraphInputs
+set_option backward.isDefEq.respectTransparency false
+
+theorem fixedSourceRun_compatible {Result : Type} {inputs : Finset HashInput} (context : Context inputs)
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) (memory : Memory)
+    (hcompatible : Compatible context memory) (value : Result) (after : Memory)
+    (hresult : fixedSourceRun context computation memory (some value, after) ≠ 0) : Compatible context after := by
+  induction computation using OracleComp.inductionOn generalizing memory value after with
+  | pure value =>
+      simp only [fixedSourceRun_pure, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not, Prod.mk.injEq] at hresult
+      exact hresult.2 ▸ hcompatible
+  | query_bind input next ih =>
+      rw [fixedSourceRun_query_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨⟨answer, middle⟩, hmiddle, hresult⟩ := hresult
+      cases answer with
+      | none =>
+          simp only [Option.elim_none, ne_eq, SPMF.pure_apply_eq_zero_iff, Prod.mk.injEq, Option.some_ne_none, false_and, not_not] at hresult
+      | some answer =>
+          exact ih answer middle (fixedSourceImpl_compatible context input memory hcompatible answer middle hmiddle) value after hresult
+
+theorem observedRun_source_memory {Result : Type} {inputs : Finset HashInput} (context : Context inputs)
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) (hinputs : sourceInputs context.key computation ⊆ inputs)
+    (state : State inputs) (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hcompatible : Compatible context state.memory) :
+    forgetState <$> observedRun context.environment context.actual context.auxiliary.seed
+      (simulateQ (adversaryImpl inputs context.key.parameter context.key.root context.words context.auxiliary.selections) computation) state =
+      fixedSourceRun context computation state.memory := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value =>
+      simp only [simulateQ_pure, observedRun, runWith_pure, map_pure, forgetState, fixedSourceRun_pure]
+  | query_bind input next ih =>
+      have hhead := (requestInputs_subset context.key input next).trans hinputs
+      have hnext := fun answer => (sourceInputs_next_subset context.key input next answer).trans hinputs
+      unfold Context.environment
+      rw [simulateQ_bind, simulateQ_spec_query, observedRun_bind, map_bind, fixedSourceRun_query_bind,
+        ← observedRun_request_memory context input hhead state hcovered hcompatible, bind_map_left]
+      apply RetainedObservation.bind_congr
+      rintro ⟨answer, after⟩ hafter
+      cases answer with
+      | none => simp only [Option.elim_none, map_pure, forgetState]
+      | some answer =>
+          have hcovered' := observedRun_rowsCovered context.key.parameter inputs context.encoding context.words context.publicReplies
+            context.auxiliary.selections context.auxiliary.rows context.actual context.auxiliary.seed _ state hcovered (some answer, after) hafter
+          have hcompatible' := observedRun_request_compatible context input hhead state hcovered hcompatible answer after hafter
+          exact ih answer (hnext answer) after hcovered' hcompatible'
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualContext.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualContext.lean
new file mode 100644
index 000000000..deec5651f
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualContext.lean
@@ -0,0 +1,116 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualHistory
+import SphincsSecurity.Proof.Residual.RetainedResidualTraceValidity
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open InterleavedResidual (Routing SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs
+set_option backward.isDefEq.respectTransparency false
+
+structure Context (inputs : Finset HashInput) where
+  key : SecretKey
+  graph : CanonicalGraphLabels
+  auxiliary : ReferenceAuxiliary inputs
+  encoding : canonicalEncodingInputs key.parameter ⊆ inputs
+  auxiliary_valid : auxiliary ∈ (referenceAuxiliarySample inputs).support
+  dummy : OtsReferenceWords
+  publicReplies : CanonicalGraphLabels
+
+def Context.words {inputs : Finset HashInput} (context : Context inputs) : OtsReferenceWords :=
+  referenceFamilyWords context.auxiliary.selections context.dummy
+
+def Context.actual {inputs : Finset HashInput} (context : Context inputs) : Labels :=
+  CanonicalCoordinate.value context.key.otsSecret context.key.ftsSecret context.graph
+
+noncomputable def Context.oracle {inputs : Finset HashInput} (context : Context inputs) : QueryImpl HashSpec Id :=
+  programmedHash context.key.parameter context.key.otsSecret context.key.ftsSecret context.graph
+    (finiteHashAnswer ∅ inputs (canonicalPrefixResidual context.key.parameter inputs context.encoding context.graph
+      context.auxiliary.selections context.auxiliary.rows context.auxiliary.seed))
+
+noncomputable def Context.environment {inputs : Finset HashInput} (context : Context inputs) :=
+  RetainedResidual.environment context.key.parameter inputs context.encoding context.words context.publicReplies context.auxiliary.selections context.auxiliary.rows
+
+def Context.EncodingMatch {inputs : Finset HashInput} (context : Context inputs) : HashInput → HashOutput → Prop :=
+  PublicEncodingMatch.Match context.key.parameter (canonicalGraphMessage context.graph) context.words context.auxiliary.selections
+
+structure Compatible {inputs : Finset HashInput} (context : Context inputs) (memory : Memory) : Prop where
+  agrees : PublicAgreement context.words memory.routing.disclosed memory.routing.known context.actual
+  replies : ∀ position, ¬CanonicalCoordinate.Hidden context.words memory.routing.disclosed (.graph position) → context.publicReplies position = context.graph position
+  cached : ResidualByteFrontend.CacheMatches context.oracle memory.external.cache
+  structural : CacheClean context.key.parameter context.words memory.routing.disclosed context.actual memory.external.cache
+  encoding : ResidualByteFrontend.ReplyClean context.EncodingMatch memory.external.cache
+
+theorem afterReply_history (parameter : PublicParameter) (memory : Memory) (input : HashInput)
+    (answer : Option HashOutput) (external : ExternalMemory) :
+    (memory.afterReply parameter input answer external).history = memory.history := by
+  cases answer with
+  | none => rfl
+  | some answer => exact observeMessage_history parameter _ _ _
+
+theorem fixedHashStep_routing (parameter : PublicParameter) (words : OtsReferenceWords) (selections : ReferenceFamily)
+    (routing : Routing) (actual : Labels) (oracle : QueryImpl HashSpec Id) (input : HashInput) (memory : Memory) :
+    (fixedHashStep parameter words selections routing actual oracle input memory).2.routing = memory.routing :=
+  congrArg Prod.fst (afterReply_history parameter memory input _ _)
+
+theorem Context.encodingMatch_known {inputs : Finset HashInput} (context : Context inputs) (memory : Memory) (hcompatible : Compatible context memory) :
+    PublicEncodingMatch.Match context.key.parameter (knownEncodingMessage memory.routing.known) context.words context.auxiliary.selections = context.EncodingMatch :=
+  PublicEncodingMatch.known_eq_original context.key.parameter context.words memory.routing.disclosed memory.routing.known
+    context.key.otsSecret context.key.ftsSecret context.graph hcompatible.agrees context.auxiliary.selections
+
+theorem fixedHashStep_compatible {inputs : Finset HashInput} (context : Context inputs) (input : HashInput)
+    (memory : Memory) (hcompatible : Compatible context memory) (answer : HashOutput)
+    (hanswer : (fixedHashStep context.key.parameter context.words context.auxiliary.selections memory.routing context.actual context.oracle input memory).1 = some answer) :
+    Compatible context (fixedHashStep context.key.parameter context.words context.auxiliary.selections memory.routing context.actual context.oracle input memory).2 := by
+  have hrouting := fixedHashStep_routing context.key.parameter context.words context.auxiliary.selections memory.routing context.actual context.oracle input memory
+  have hstep := ResidualByteFrontend.fixedStep_preserves context.key.parameter context.words memory.routing.disclosed memory.routing.known
+    context.actual context.oracle input memory.external hcompatible.cached hcompatible.structural
+  rw [← fixedHashStep_external context.key.parameter context.words context.auxiliary.selections memory.routing context.actual context.oracle input memory] at hstep
+  refine ⟨?_, ?_, hstep.1, ?_, ?_⟩
+  · rw [hrouting]; exact hcompatible.agrees
+  · rw [hrouting]; exact hcompatible.replies
+  · rw [hrouting]; exact hstep.2.1
+  · have hclean := hcompatible.encoding
+    rw [← context.encodingMatch_known memory hcompatible] at hclean ⊢
+    have h := ResidualByteFrontend.checkedFixedStep_replyClean context.key.parameter context.words memory.routing.disclosed memory.routing.known
+      context.actual _ context.oracle input memory.external hclean answer hanswer
+    simpa only [fixedHashStep, afterReply_external, ResidualByteFrontend.checkedResult] using h
+
+theorem Compatible.afterSigning {inputs : Finset HashInput} (context : Context inputs) (memory : Memory)
+    (hcompatible : Compatible context memory) (message : Message) (record : SigningRecord)
+    (htrace : TraceValid context.key.parameter context.oracle record.2)
+    (hcompletion : ∃ planned : PublicSigningRecord,
+      completePublicSigningRecord (fun index tree leaf => context.actual (.ftsStart index tree leaf)) planned = record) :
+    Compatible context ((memory.applyBoundary record.2).recordSigning message record) := by
+  have hagrees : PublicAgreement context.words (memory.routing.afterSigning record).disclosed
+      (memory.routing.afterSigning record).known context.actual := by
+    obtain ⟨planned, rfl⟩ := hcompletion
+    exact memory.routing.afterSigning_completed_agreement context.words context.actual hcompatible.agrees planned
+  refine ⟨hagrees, ?_, ?_, ?_, ?_⟩
+  · intro position hpublic
+    apply hcompatible.replies position
+    rw [InterleavedResidual.hidden_graph_disclosed context.words memory.routing.disclosed (memory.routing.afterSigning record).disclosed position]
+    exact hpublic
+  · exact applyBoundary_cacheMatches context.key.parameter context.oracle memory record.2 htrace hcompatible.cached
+  · exact memory.routing.afterSigning_cacheClean record context.key.parameter context.words context.actual _
+      (applyBoundary_cacheClean context.key.parameter context.oracle context.words memory.routing.disclosed context.actual memory record.2 htrace hcompatible.structural)
+  · exact applyBoundary_encodingClean context.key.parameter context.oracle context.words (canonicalGraphMessage context.graph)
+      context.auxiliary.selections memory record.2 htrace hcompatible.encoding
+
+theorem originalSigning_compatible {inputs : Finset HashInput} (context : Context inputs) (memory : Memory)
+    (hcompatible : Compatible context memory) (message : Message) (record : SigningRecord)
+    (hrecord : 𝒟[fixedBoundaryRun context.key.parameter context.oracle (signWithView context.key message)] record ≠ 0) :
+    Compatible context ((memory.applyBoundary record.2).recordSigning message record) := by
+  apply Compatible.afterSigning context memory hcompatible message record
+    (fixedBoundaryRun_traceValid context.key.parameter context.oracle _ record hrecord)
+  have h := fixedBoundaryRun_signWithView_prefix_public context.key inputs context.encoding context.graph context.auxiliary context.auxiliary_valid
+    context.dummy memory.routing.disclosed memory.routing.known hcompatible.agrees message
+  have h := congrArg evalDist h
+  change 𝒟[fixedBoundaryRun context.key.parameter context.oracle (signWithView context.key message)] = _ at h
+  rw [h, evalDist_map, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hrecord
+  obtain ⟨planned, _, hrecord⟩ := hrecord
+  simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hrecord
+  exact ⟨planned, hrecord.symm⟩
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCoverageStep.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCoverageStep.lean
new file mode 100644
index 000000000..49d069381
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualCoverageStep.lean
@@ -0,0 +1,175 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CertificateMonitor
+import SphincsSecurity.Proof.Fts.DigestCompletionBank
+import SphincsSecurity.Proof.Residual.RetainedResidualSigningLaw
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec ENNReal CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] signDigestLoop bankedTargetEnvelope completedTargetBank targetCreationPrice targetCreationMultiplier
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def completedSigningBankValue (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat)
+    (required : Finset FtsTree) (log : QueryLog SigningSpec) (bank : HashInput → Bool) (message : Message)
+    (result : (Option Signature × Option FewTimeView) × QueryCache HashSpec) : ENNReal :=
+  let after := (result.2, log ++ [⟨message, result.1.1⟩])
+  bankedTargetEnvelope key reuse budget signatures required after (completedTargetBank key required after bank) false
+
+def proposalOfSigningRecord (message : Message) (record : SigningRecord) (cache : QueryCache HashSpec) (index : Index) :
+    ProposalExecutionRecord (.inr message) := ⟨record.1.1, cache, record.2, record.1.2, index⟩
+
+theorem bankedProposalRecordValue_le_completedSigningBank (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat)
+    (required : Finset FtsTree) (cover : CoverLogState) (bank : HashInput → Bool) (message : Message)
+    (record : ProposalExecutionRecord (.inr message)) (stopped : Bool) :
+    bankedProposalRecordValue key reuse budget signatures required cover bank (.inr message) record stopped ≤
+      completedSigningBankValue key reuse budget signatures required cover.2 bank message
+        ((record.output, record.selectedView), record.cache) := by
+  unfold bankedProposalRecordValue completedSigningBankValue proposalRecordLogState signingLogFragment
+  apply (bankedTargetEnvelope_budget_mono key reuse signatures required _ _ stopped (Nat.sub_le budget record.trace.hashCalls)).trans
+  unfold bankedTargetEnvelope
+  exact bankedCacheWeight_discard_le _ _ _ _ _
+
+theorem expected_digestCompletionValue_bank_le (key : SecretKey) (reuse : ENNReal) (budget signatures : Nat)
+    (required : Finset FtsTree) (cover : CoverLogState) (bank : HashInput → Bool) (message : Message)
+    (known : Labels) (words : OtsReferenceWords) (selections : ReferenceFamily) (actual : Labels)
+    (hsigned : SigningDigestsCached key.parameter cover.1 key.root cover.2)
+    (hreuse : exactDigestReuseWeight key message cover.1 ≤ reuse) :
+    (∑' result, Pr[= result | digestCompletionValue known words selections actual <$>
+        (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run cover.1] *
+      completedSigningBankValue key reuse budget signatures required cover.2 bank message result) ≤
+      bankedTargetEnvelope key reuse budget (signatures + 1) required cover bank false +
+        targetCreationMultiplier key cover.1 (.inr message) * targetCreationPrice key reuse budget (signatures + 1) required cover := by
+  have h := expected_digestCompletion_bankedTarget_le key reuse budget signatures required cover bank message
+    (fun loop => pure (digestCompletionValue known words selections actual loop)) id
+    (by
+      intro loop _ result hr
+      rw [support_pure, Set.mem_singleton_iff] at hr
+      subst result
+      exact digestCompletionValue_preservesMessages key known words selections actual loop)
+    (fun _ => false) hsigned hreuse
+  change (∑' result, Pr[= result | digestCompletionValue known words selections actual <$>
+    (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run cover.1] *
+    completedSigningBankValue key reuse budget signatures required cover.2 bank message result) ≤ _ at h
+  conv at h =>
+    rhs
+    arg 2
+    rw [← targetCreationMultiplier_sign_mul_price key reuse budget signatures required cover message]
+  exact h.trans (add_le_add le_rfl (mul_le_mul' le_rfl
+    (targetCreationPrice_signatures_mono key reuse budget required cover (Nat.le_succ _))))
+
+attribute [local irreducible] lazyRun completedSigningBankValue digestCompletionValue environment ResidualByteFrontend.jointSigningProgram
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+  (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem expected_lazySigning_bank_le (routing : Routing) (key : SecretKey) (hparameter : key.parameter = parameter)
+    (reuse : ENNReal) (budget signatures : Nat) (required : Finset FtsTree)
+    (cover : CoverLogState) (bank : HashInput → Bool) (message : Message)
+    (hinputs : hashInputs (signDigestLoop digestAttemptLimit key message) ⊆ inputs) (state : State inputs)
+    (hcache : state.memory.external.cache = cover.1)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hsigned : SigningDigestsCached key.parameter cover.1 key.root cover.2)
+    (hreuse : exactDigestReuseWeight key message cover.1 ≤ reuse) :
+    (∑' result, Pr[= result | lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+        (simulateQ (embed inputs routing)
+          (ResidualByteFrontend.jointSigningProgram inputs parameter key.root routing.known words selections message)) state] *
+      result.1.elim 0 (fun record => completedSigningBankValue key reuse budget signatures required cover.2 bank message
+        (record.1, result.2.memory.external.cache))) ≤
+      bankedTargetEnvelope key reuse budget (signatures + 1) required cover bank false +
+        targetCreationMultiplier key cover.1 (.inr message) * targetCreationPrice key reuse budget (signatures + 1) required cover := by
+  let weight : Option (Option Signature × Option FewTimeView) × QueryCache HashSpec → ENNReal := fun result =>
+    result.1.elim 0 (fun value => completedSigningBankValue key reuse budget signatures required cover.2 bank message (value, result.2))
+  have h := congrArg (fun law : SPMF (Option (Option Signature × Option FewTimeView) × QueryCache HashSpec) =>
+    ∑' result, Pr[= result | law] * weight result)
+      (lazyRun_jointSigningProgram_digestLaw parameter inputs hencoding words publicReplies selections rows routing key hparameter
+        message hinputs state ha hcovered)
+  rw [tsum_probOutput_map_mul, tsum_probOutput_map_mul, tsum_probOutput_bind_mul] at h
+  simp only [tsum_probOutput_map_mul, weight, eraseSigningTrace, cacheResult, Option.elim_map,
+    Prod.map_fst, Prod.map_snd, id_eq, Option.elim_some, Function.comp_def, hcache] at h
+  rw [h]
+  calc
+    _ ≤ ∑' actual, Pr[= actual | UniformTableCompletion.complete state.candidates] *
+        (bankedTargetEnvelope key reuse budget (signatures + 1) required cover bank false +
+          targetCreationMultiplier key cover.1 (.inr message) * targetCreationPrice key reuse budget (signatures + 1) required cover) := by
+      apply ENNReal.tsum_le_tsum
+      intro actual
+      apply mul_le_mul' le_rfl
+      have hbound := expected_digestCompletionValue_bank_le key reuse budget signatures required cover bank message
+        routing.known words selections actual hsigned hreuse
+      generalize hcomputation : digestCompletionValue routing.known words selections actual <$>
+        (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run cover.1 = computation at hbound ⊢
+      simpa only [Prod.mk.eta, probOutput_def, SPMF.evalDist_def] using hbound
+    _ ≤ _ := by
+      rw [ENNReal.tsum_mul_right]
+      exact mul_le_of_le_one_left' tsum_probOutput_le_one
+
+theorem expected_lazySigning_certificateMonitor_le (routing : Routing) (key : SecretKey) (hparameter : key.parameter = parameter)
+    (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule) (message : Message)
+    (monitor : CertificateMonitorState)
+    (length : Option SigningRecord × State inputs → Nat) (index : Option SigningRecord × State inputs → Index)
+    (hinputs : hashInputs (signDigestLoop digestAttemptLimit key message) ⊆ inputs) (state : State inputs)
+    (hcache : state.memory.external.cache = monitor.1)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) :
+    (∑' result, Pr[= result | lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+        (simulateQ (embed inputs routing)
+          (ResidualByteFrontend.jointSigningProgram inputs parameter key.root routing.known words selections message)) state] *
+      result.1.elim 0 (fun record => certificateMonitorPotential key budget required
+        (originalProposalAdvance (certificateMonitorUpdate key budget required stopAfter) (.inr message) monitor (length result)
+          (proposalOfSigningRecord message record result.2.memory.external.cache (index result))))) ≤
+      certificateMonitorPotential key budget required monitor + certificateMonitorCharge key budget required (.inr message) monitor := by
+  by_cases hactive : CertificateMonitorActive key budget (.inr message) monitor
+  · have hdata := hactive
+    obtain ⟨hlive, ⟨hsigned, hcapacity, _⟩, hvalid, _⟩ := hdata
+    have hremaining : signatureLimit - (monitor.2.log.length + 1) + 1 = signatureLimit - monitor.2.log.length := by
+      change monitor.2.log.length < signatureLimit at hvalid
+      omega
+    have hreuse := exactDigestReuseWeight_le_near_uniform_of_clean_cache key monitor.1 monitor.2.spent
+      hcapacity.spent_le hcapacity.cache_le hcapacity.no_deficit message
+    calc
+      _ ≤ ∑' result, Pr[= result | lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+          (simulateQ (embed inputs routing)
+            (ResidualByteFrontend.jointSigningProgram inputs parameter key.root routing.known words selections message)) state] *
+        result.1.elim 0 (fun record => completedSigningBankValue key nearUniformDigestReuseWeight
+          (budget - monitor.2.spent) (signatureLimit - (monitor.2.log.length + 1)) required monitor.2.log monitor.2.bank message
+          (record.1, result.2.memory.external.cache)) := by
+        apply ENNReal.tsum_le_tsum
+        intro result
+        apply mul_le_mul' le_rfl
+        cases hrecord : result.1 with
+        | none => exact le_rfl
+        | some record =>
+            simp only [Option.elim_some, certificateMonitorPotential_advance_active key budget required stopAfter
+              (.inr message) monitor _ _ hactive, signingLogFragment, List.length_append, List.length_singleton]
+            exact bankedProposalRecordValue_le_completedSigningBank key nearUniformDigestReuseWeight
+              (budget - monitor.2.spent) (signatureLimit - (monitor.2.log.length + 1)) required (certificateMonitorCoverState monitor)
+              monitor.2.bank message (proposalOfSigningRecord message record result.2.memory.external.cache (index result)) _
+      _ ≤ _ := by
+        have h := expected_lazySigning_bank_le parameter inputs hencoding words publicReplies selections rows routing key hparameter
+          nearUniformDigestReuseWeight (budget - monitor.2.spent) (signatureLimit - (monitor.2.log.length + 1)) required
+          (certificateMonitorCoverState monitor) monitor.2.bank message hinputs state hcache ha hcovered hsigned hreuse
+        rw [hremaining] at h
+        simpa only [certificateMonitorPotential, certificateMonitorCoverState, hlive, certificateMonitorCharge, if_pos hactive] using h
+  · rw [certificateMonitorCharge, if_neg hactive, add_zero]
+    simp only [certificateMonitorPotential_advance_inactive key budget required stopAfter (.inr message) monitor _ _ hactive]
+    calc
+      _ ≤ ∑' result, Pr[= result | lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+          (simulateQ (embed inputs routing)
+            (ResidualByteFrontend.jointSigningProgram inputs parameter key.root routing.known words selections message)) state] *
+          certificateBankCount monitor.2.bank := by
+        apply ENNReal.tsum_le_tsum
+        intro result
+        apply mul_le_mul' le_rfl
+        cases result.1 <;> simp only [Option.elim_none, Option.elim_some, zero_le, le_refl]
+      _ ≤ certificateBankCount monitor.2.bank := by
+        rw [ENNReal.tsum_mul_right]
+        exact mul_le_of_le_one_left' tsum_probOutput_le_one
+      _ ≤ _ := by
+        unfold certificateMonitorPotential bankedTargetEnvelope
+        exact certificateBankCount_le_bankedCacheWeight _ _ _ _ _
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualDigestLaw.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualDigestLaw.lean
new file mode 100644
index 000000000..deb4ca153
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualDigestLaw.lean
@@ -0,0 +1,130 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Reference.CausalPublicSigning
+import SphincsSecurity.Proof.Residual.RetainedResidualMessageKernel
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs
+set_option backward.isDefEq.respectTransparency false
+
+def cacheResult {Result : Type} {inputs : Finset HashInput} (result : Option Result × State inputs) :
+    Option Result × QueryCache HashSpec := (result.1, result.2.memory.external.cache)
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+  (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+noncomputable def lazyByteRun {Result : Type} (routing : Routing)
+    (computation : OracleComp OracleWorld Result) (state : State inputs) : SPMF (Option Result × State inputs) :=
+  lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+    (simulateQ (embed inputs routing) (simulateQ (ResidualByteFrontend.checkedTranslate inputs
+      (PublicEncodingMatch.Match parameter (knownEncodingMessage routing.known) words selections)) computation)) state
+
+theorem lazyByteRun_pure {Result : Type} (routing : Routing) (value : Result) (state : State inputs) :
+    lazyByteRun parameter inputs hencoding words publicReplies selections rows routing (pure value) state =
+      pure (some value, state) := by
+  simp only [lazyByteRun, simulateQ_pure, lazyRun, runWith_pure]
+
+theorem lazyByteRun_random_bind {Result : Type} (routing : Routing) (input : unifSpec.Domain)
+    (next : unifSpec.Range input → OracleComp OracleWorld Result) (state : State inputs) :
+    lazyByteRun parameter inputs hencoding words publicReplies selections rows routing
+      (liftM (OracleWorld.query (.inl input)) >>= next) state =
+      ((liftM (PMF.uniformOfFintype (unifSpec.Range input)) : SPMF _) >>= fun answer =>
+        lazyByteRun parameter inputs hencoding words publicReplies selections rows routing (next answer) state) := by
+  simp only [lazyByteRun, simulateQ_bind, simulateQ_spec_query, ResidualByteFrontend.checkedTranslate, embed]
+  rw [lazyRun, runWith_query_bind]
+  simp only [lazyImpl, environment, ResidualByteFrontend.environment, OptionT.run_mk, StateT.run_mk,
+    ← PMF.monad_map_eq_map, liftM_map, bind_map_left, bind_assoc, pure_bind, Option.elim_some, afterControl]
+  rfl
+
+theorem lazyByteRun_message_bind {Result : Type} (routing : Routing) (input : HashInput) (hin : input ∈ inputs)
+    (hmessage : FtsProbeSimulation.MessageHashInput parameter input)
+    (next : HashOutput → OracleComp OracleWorld Result) (state : State inputs)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) :
+    lazyByteRun parameter inputs hencoding words publicReplies selections rows routing
+      (liftM (OracleWorld.query (.inr input)) >>= next) state =
+      (𝒟[(randomOracle (spec := HashSpec) input).run state.memory.external.cache] >>= fun result =>
+        lazyByteRun parameter inputs hencoding words publicReplies selections rows routing
+          (next result.1) (messageState parameter state ⟨input, hin⟩ result.1)) := by
+  simp only [lazyByteRun, simulateQ_bind, simulateQ_spec_query, ResidualByteFrontend.checkedTranslate, dif_pos hin]
+  rw [checkedHashQuery_message parameter inputs words selections routing ⟨input, hin⟩ hmessage,
+    lazyRun_bind, lazyRun_hashQuery_message parameter inputs hencoding words publicReplies selections rows routing
+      ⟨input, hin⟩ hmessage state hcovered, bind_map_left]
+  rfl
+
+theorem lazyByteRun_message_rom {Result : Type} (routing : Routing)
+    (computation : OracleComp OracleWorld Result) (hinputs : hashInputs computation ⊆ inputs)
+    (hmessage : ResidualByteFrontend.MessageOnly parameter computation) (state : State inputs)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) :
+    cacheResult <$> lazyByteRun parameter inputs hencoding words publicReplies selections rows routing computation state =
+      Prod.map some id <$> 𝒟[(simulateQ romImpl computation).run state.memory.external.cache] := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value =>
+      simp only [lazyByteRun_pure, simulateQ_pure, StateT.run_pure, evalDist_pure, map_pure]
+      rfl
+  | query_bind input next ih =>
+      have hnext : ∀ answer, hashInputs (next answer) ⊆ inputs :=
+        fun answer => (hashInputs_next_subset input next answer).trans hinputs
+      have hmnext : ∀ answer, ResidualByteFrontend.MessageOnly parameter (next answer) :=
+        fun answer row hrow => hmessage row ((hashInputs_next_subset input next answer) hrow)
+      cases input with
+      | inl input =>
+          have hrun : (romImpl (.inl input)).run state.memory.external.cache =
+              (fun answer => (answer, state.memory.external.cache)) <$>
+                (liftM (unifSpec.query input) : ProbComp _) := rfl
+          rw [lazyByteRun_random_bind]
+          simp only [simulateQ_bind, simulateQ_spec_query, StateT.run_bind, hrun,
+            evalDist_bind, evalDist_query, bind_map_left, map_bind]
+          apply congrArg ((liftM (PMF.uniformOfFintype (unifSpec.Range input)) : SPMF _) >>= ·)
+          funext answer
+          exact ih answer (hnext answer) (hmnext answer) state hcovered
+      | inr input =>
+          change HashOutput → OracleComp OracleWorld Result at next
+          have hin := hinputs (mem_hashInputs_hash_bind input next)
+          have hm := hmessage input (mem_hashInputs_hash_bind input next)
+          rw [lazyByteRun_message_bind parameter inputs hencoding words publicReplies selections rows routing input hin hm next state hcovered]
+          simp only [simulateQ_bind, simulateQ_spec_query, StateT.run_bind,
+            evalDist_bind, map_bind]
+          apply RetainedObservation.bind_congr
+          intro result hresult
+          have hs : result ∈ support ((randomOracle input).run state.memory.external.cache) :=
+            (mem_support_iff _ _).mpr hresult
+          obtain ⟨hcache, hrows⟩ := randomOracle_messageState parameter inputs state hcovered ⟨input, hin⟩ result hs
+          rw [ih result.1 (hnext result.1) (hmnext result.1) _ hrows, hcache]
+
+theorem lazyByteRun_message_support {Result : Type} (routing : Routing)
+    (computation : OracleComp OracleWorld Result) (hinputs : hashInputs computation ⊆ inputs)
+    (hmessage : ResidualByteFrontend.MessageOnly parameter computation) (state : State inputs)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) (result : Option Result × State inputs)
+    (hresult : lazyByteRun parameter inputs hencoding words publicReplies selections rows routing computation state result ≠ 0) :
+    (∃ value, result.1 = some value) ∧ result.2.candidates = state.candidates := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      simp only [lazyByteRun_pure, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact ⟨⟨value, rfl⟩, rfl⟩
+  | query_bind input next ih =>
+      have hnext : ∀ answer, hashInputs (next answer) ⊆ inputs :=
+        fun answer => (hashInputs_next_subset input next answer).trans hinputs
+      have hmnext : ∀ answer, ResidualByteFrontend.MessageOnly parameter (next answer) :=
+        fun answer row hrow => hmessage row ((hashInputs_next_subset input next answer) hrow)
+      cases input with
+      | inl input =>
+          rw [lazyByteRun_random_bind, RetainedObservation.bind_nonzero] at hresult
+          obtain ⟨answer, _, hresult⟩ := hresult
+          exact ih answer (hnext answer) (hmnext answer) state hcovered result hresult
+      | inr input =>
+          change HashOutput → OracleComp OracleWorld Result at next
+          have hin := hinputs (mem_hashInputs_hash_bind input next)
+          have hm := hmessage input (mem_hashInputs_hash_bind input next)
+          rw [lazyByteRun_message_bind parameter inputs hencoding words publicReplies selections rows routing input hin hm next state hcovered,
+            RetainedObservation.bind_nonzero] at hresult
+          obtain ⟨reply, hreply, hresult⟩ := hresult
+          obtain ⟨_, hrows⟩ := randomOracle_messageState parameter inputs state hcovered ⟨input, hin⟩ reply
+            ((mem_support_iff _ _).mpr hreply)
+          exact ih reply.1 (hnext reply.1) (hmnext reply.1) _ hrows result hresult
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualEncodingHistory.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualEncodingHistory.lean
new file mode 100644
index 000000000..cd60698d3
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualEncodingHistory.lean
@@ -0,0 +1,195 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualOriginalBudget
+import SphincsSecurity.Proof.Residual.RetainedResidualSigningCandidates
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting UniformTableCompletion
+open AdaptiveResidualLabels hiding World State Environment
+open FtsProbeSimulation (unloggedRetainedRestComputation)
+open InterleavedResidual (Routing SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs sourceInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+theorem knownEncodingMessage_afterSigning (routing : Routing) (record : SigningRecord) :
+    knownEncodingMessage (routing.afterSigning record).known = knownEncodingMessage routing.known := by
+  funext position
+  exact routing.afterSigning_graph record _
+
+section Local
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+  (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem checkedHashResult_encodingClean (routing : Routing) (actual : Labels) (seed : inputs → HashOutput)
+    (input : inputs) (state : State inputs) (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hclean : ResidualByteFrontend.ReplyClean
+      (PublicEncodingMatch.Match parameter (knownEncodingMessage routing.known) words selections) state.memory.external.cache)
+    (hlive : (checkedHashResult parameter inputs hencoding words publicReplies selections rows routing actual seed input state).1 ≠ none) :
+    ResidualByteFrontend.ReplyClean
+      (PublicEncodingMatch.Match parameter (knownEncodingMessage routing.known) words selections)
+      (checkedHashResult parameter inputs hencoding words publicReplies selections rows routing actual seed input state).2.memory.external.cache := by
+  let actions := ResidualByteAction.freshPrefix parameter inputs hencoding words routing.disclosed routing.known publicReplies selections rows
+  have hp := congrArg (fun result : Option HashOutput × ResidualByteFrontend.State inputs => (result.1, result.2.memory))
+    (hashResult_project parameter inputs hencoding words publicReplies selections rows routing actual seed input state)
+  have hf := ResidualByteFrontend.hashQueryResult_project parameter inputs words routing.disclosed routing.known actions
+    actual seed input (project state) hcovered
+    (ResidualByteAction.freshPrefix_local parameter inputs hencoding words routing.disclosed routing.known publicReplies selections rows input)
+  have h := congrArg (ResidualByteFrontend.checkedResult
+    (PublicEncodingMatch.Match parameter (knownEncodingMessage routing.known) words selections) input.val) (hp.trans hf)
+  change ((checkedHashResult parameter inputs hencoding words publicReplies selections rows routing actual seed input state).1,
+    (checkedHashResult parameter inputs hencoding words publicReplies selections rows routing actual seed input state).2.memory.external) = _ at h
+  have hanswer := congrArg Prod.fst h
+  have hcache := congrArg (fun result => result.2.cache) h
+  rw [hanswer] at hlive
+  rw [hcache]
+  generalize ResidualByteFrontend.publicCachedReply inputs actions actual seed input (project state).memory = answer at hlive ⊢
+  cases answer with
+  | none => exact False.elim (hlive rfl)
+  | some answer =>
+      dsimp only [ResidualByteFrontend.checkedResult, Option.bind_some] at hlive ⊢
+      split at hlive
+      · exact False.elim (hlive rfl)
+      · rename_i hsafe
+        exact ResidualByteFrontend.replyClean_store _ _ hclean input.val answer hsafe
+
+theorem lazyByteRun_bind {A B : Type} (routing : Routing) (computation : OracleComp OracleWorld A)
+    (next : A → OracleComp OracleWorld B) (state : State inputs) :
+    lazyByteRun parameter inputs hencoding words publicReplies selections rows routing (computation >>= next) state =
+      (lazyByteRun parameter inputs hencoding words publicReplies selections rows routing computation state >>= fun result =>
+        result.1.elim (pure (none, result.2)) (fun answer =>
+          lazyByteRun parameter inputs hencoding words publicReplies selections rows routing (next answer) result.2)) := by
+  simp only [lazyByteRun, simulateQ_bind, lazyRun_bind]
+
+theorem lazyByteRun_encodingClean {Result : Type} (routing : Routing) (computation : OracleComp OracleWorld Result)
+    (hinputs : hashInputs computation ⊆ inputs) (state : State inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hclean : ResidualByteFrontend.ReplyClean
+      (PublicEncodingMatch.Match parameter (knownEncodingMessage routing.known) words selections) state.memory.external.cache)
+    (result : Option Result × State inputs)
+    (hresult : lazyByteRun parameter inputs hencoding words publicReplies selections rows routing computation state result ≠ 0)
+    (hlive : result.1 ≠ none) :
+    ResidualByteFrontend.ReplyClean
+      (PublicEncodingMatch.Match parameter (knownEncodingMessage routing.known) words selections) result.2.memory.external.cache := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      simp only [lazyByteRun_pure, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact hclean
+  | query_bind input next ih =>
+      have hnext : ∀ answer, hashInputs (next answer) ⊆ inputs :=
+        fun answer => (hashInputs_next_subset input next answer).trans hinputs
+      cases input with
+      | inl input =>
+          rw [lazyByteRun_random_bind, RetainedObservation.bind_nonzero] at hresult
+          obtain ⟨answer, _, hresult⟩ := hresult
+          exact ih answer (hnext answer) state ha hcovered hclean result hresult hlive
+      | inr input =>
+          have hin : input ∈ inputs := hinputs (mem_hashInputs_hash_bind input next)
+          rw [lazyByteRun_bind, RetainedObservation.bind_nonzero] at hresult
+          obtain ⟨middle, hmiddle, hresult⟩ := hresult
+          have ha' := lazyRun_nonempty (environment parameter inputs hencoding words publicReplies selections rows) _ state ha middle hmiddle
+          have hcovered' := lazyRun_rowsCovered parameter inputs hencoding words publicReplies selections rows _ state ha hcovered middle hmiddle
+          rcases middle with ⟨answer, after⟩
+          cases answer with
+          | none =>
+              simp only [Option.elim_none, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+              subst result
+              exact False.elim (hlive rfl)
+          | some answer =>
+              obtain ⟨actual, seed, heq⟩ := lazyByteRun_hash_result parameter inputs hencoding words publicReplies selections rows
+                routing input hin state ha (some answer, after) hmiddle
+              have hs := checkedHashResult_encodingClean parameter inputs hencoding words publicReplies selections rows routing actual seed
+                ⟨input, hin⟩ state hcovered hclean (by rw [← heq]; simp)
+              rw [← heq] at hs
+              exact ih answer (hnext answer) after ha' hcovered' hs result hresult hlive
+
+theorem lazyRun_jointSigningProgram_encodingClean (routing : Routing) (root : Digest) (message : Message)
+    (hinputs : hashInputs (ResidualByteFrontend.publicSigningWork parameter root routing.known words selections message) ⊆ inputs)
+    (state : State inputs) (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hclean : ResidualByteFrontend.ReplyClean
+      (PublicEncodingMatch.Match parameter (knownEncodingMessage routing.known) words selections) state.memory.external.cache)
+    (result : Option SigningRecord × State inputs)
+    (hresult : lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+      (simulateQ (embed inputs routing)
+        (ResidualByteFrontend.jointSigningProgram inputs parameter root routing.known words selections message)) state result ≠ 0) :
+    ResidualByteFrontend.ReplyClean
+      (PublicEncodingMatch.Match parameter (knownEncodingMessage routing.known) words selections) result.2.memory.external.cache := by
+  rw [ResidualByteFrontend.jointSigningProgram, simulateQ_bind, lazyRun_bind, RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨middle, hmiddle, hresult⟩ := hresult
+  rw [← lazyByteRun] at hmiddle
+  obtain ⟨⟨work, hwork⟩, hcandidates⟩ := lazyByteRun_message_support parameter inputs hencoding words publicReplies selections rows
+    routing _ hinputs (ResidualByteFrontend.publicSigningWork_messageOnly parameter root routing.known words selections message)
+    state hcovered middle hmiddle
+  have hs := lazyByteRun_encodingClean parameter inputs hencoding words publicReplies selections rows routing _ hinputs state ha hcovered hclean
+    middle hmiddle (by rw [hwork]; simp)
+  have ha' : ∀ coordinate, (middle.2.candidates coordinate).Nonempty := by rw [hcandidates]; exact ha
+  rw [hwork, Option.elim_some] at hresult
+  obtain ⟨actual, _, hmemory⟩ := lazyRun_completeWork_support parameter inputs hencoding words publicReplies selections rows
+    routing work middle.2 ha' result hresult
+  rw [hmemory]
+  exact hs
+
+omit parameter hencoding in
+theorem lazyRun_request_encodingClean (key : SecretKey)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (input : (OracleWorld + SigningSpec).Domain)
+    (hinputs : requestInputs key input ⊆ inputs) (state : State inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hclean : ResidualByteFrontend.ReplyClean
+      (PublicEncodingMatch.Match key.parameter (knownEncodingMessage state.memory.routing.known) words selections) state.memory.external.cache)
+    (result : Option ((OracleWorld + SigningSpec).Range input) × State inputs)
+    (hresult : lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+      (adversaryImpl inputs key.parameter key.root words selections input) state result ≠ 0)
+    (hlive : result.1 ≠ none) :
+    ResidualByteFrontend.ReplyClean
+      (PublicEncodingMatch.Match key.parameter (knownEncodingMessage result.2.memory.routing.known) words selections) result.2.memory.external.cache := by
+  cases input with
+  | inl input =>
+      change lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+        (externalProgram inputs key.parameter words selections (liftM (OracleWorld.query input))) state result ≠ 0 at hresult
+      rw [lazyRun_externalProgram] at hresult
+      have hrouting := lazyRun_embed_routing key.parameter inputs hencoding words publicReplies selections rows
+        state.memory.routing _ state ha result hresult
+      rw [hrouting]
+      exact lazyByteRun_encodingClean key.parameter inputs hencoding words publicReplies selections rows state.memory.routing
+        _ hinputs state ha hcovered hclean result hresult hlive
+  | inr message =>
+      change lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+        (signingProgram inputs key.parameter key.root words selections message) state result ≠ 0 at hresult
+      rw [lazyRun_signingProgram key inputs hencoding words publicReplies selections rows message state,
+        map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨raw, hraw, hresult⟩ := hresult
+      have hwork := (ResidualByteFrontend.hashInputs_publicSigningWork_subset_signWithView key
+        state.memory.routing.known words selections message).trans hinputs
+      have hs := lazyRun_jointSigningProgram_encodingClean key.parameter inputs hencoding words publicReplies selections rows
+        state.memory.routing key.root message hwork state ha hcovered hclean raw hraw
+      have hrouting := lazyRun_embed_routing key.parameter inputs hencoding words publicReplies selections rows
+        state.memory.routing _ state ha raw hraw
+      rw [ResidualByteFrontend.hashInputs_publicSigningWork] at hwork
+      obtain ⟨record, hrecord⟩ := lazyRun_jointSigningProgram_some key.parameter inputs hencoding words publicReplies selections rows
+        state.memory.routing key.root message hwork state ha hcovered raw hraw
+      simp only [Function.comp_def, hrecord, Option.elim_some, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      change ResidualByteFrontend.ReplyClean
+        (PublicEncodingMatch.Match key.parameter (knownEncodingMessage (raw.2.memory.routing.afterSigning record).known) words selections)
+        raw.2.memory.external.cache
+      rw [knownEncodingMessage_afterSigning, hrouting]
+      exact hs
+
+end Local
+
+theorem referenceEncodingAuxiliary_select (encoding : ReferenceEncodingAuxiliary)
+    (hencoding : encoding ∈ referenceEncodingAuxiliarySample.support) (position : EncodingPosition) :
+    FirstSuccessTable.select decodeEncodingOutput (fun counter => encoding.rows (position, counter)) = encoding.selections position :=
+  referenceAuxiliarySample_select ∅ ⟨encoding.selections, encoding.rows, fun _ => 0⟩
+    (referenceEncodingAuxiliary_support_seed ∅ encoding hencoding (fun _ => 0)) position
+
+variable (key : SecretKey) (adversary : Adversary) (encoding : ReferenceEncodingAuxiliary) (dummy : OtsReferenceWords)
+  (exposed : InitialPublicLabels (referenceFamilyWords encoding.selections dummy)) (high : CanonicalGraphHighHalves)
+  (q : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule) (stopped : Bool)
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualEnvelope.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualEnvelope.lean
new file mode 100644
index 000000000..d6f2c94d9
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualEnvelope.lean
@@ -0,0 +1,67 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Ots.ReferencePrefixGame
+import SphincsSecurity.Proof.Residual.RetainedResidualSource
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs sourceInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition canonicalGraphGameInputs
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable local instance keyFintype : Fintype SecretKey := by
+  classical
+  exact Fintype.ofEquiv
+    (PublicParameter × Digest × (Layer → TreeIndex → LeafIndex → ChainIndex → Digest) × (Index → FtsTree → FtsLeaf → Digest))
+    { toFun := fun key => ⟨key.1, key.2.1, key.2.2.1, key.2.2.2⟩
+      invFun := fun key => (key.parameter, key.root, key.otsSecret, key.ftsSecret)
+      left_inv := fun _ => rfl
+      right_inv := fun _ => rfl }
+
+attribute [local irreducible] keyFintype signatureFintype
+
+noncomputable def verificationInputs (key : SecretKey) : Finset HashInput :=
+  Finset.univ.biUnion fun message : Message => Finset.univ.biUnion fun signature : Signature =>
+    hashInputs (scheme.verify ⟨key.root, key.parameter⟩ message signature)
+
+noncomputable def gameInputs (adversary : Adversary) : Finset HashInput :=
+  canonicalGraphGameInputs adversary ∪ Finset.univ.biUnion fun key : SecretKey =>
+    sourceInputs key (adversary.main ⟨key.root, key.parameter⟩) ∪ verificationInputs key
+
+theorem sourceInputs_subset_gameInputs (adversary : Adversary) (key : SecretKey) :
+    sourceInputs key (adversary.main ⟨key.root, key.parameter⟩) ⊆ gameInputs adversary := by
+  intro input hinput
+  rw [gameInputs, Finset.mem_union]
+  exact Or.inr (Finset.mem_biUnion.mpr ⟨key, Finset.mem_univ _, Finset.mem_union_left _ hinput⟩)
+
+theorem verifyInputs_subset_gameInputs (adversary : Adversary) (key : SecretKey) (forgery : Forgery) :
+    hashInputs (scheme.verify ⟨key.root, key.parameter⟩ forgery.message forgery.signature) ⊆ gameInputs adversary := by
+  intro input hinput
+  rw [gameInputs, Finset.mem_union]
+  apply Or.inr
+  apply Finset.mem_biUnion.mpr
+  refine ⟨key, Finset.mem_univ _, Finset.mem_union_right _ ?_⟩
+  rw [verificationInputs, Finset.mem_biUnion]
+  exact ⟨forgery.message, Finset.mem_univ _, Finset.mem_biUnion.mpr ⟨forgery.signature, Finset.mem_univ _, hinput⟩⟩
+
+theorem canonicalEncodingInputs_subset_retainedGameInputs (adversary : Adversary) (parameter : PublicParameter) :
+    canonicalEncodingInputs parameter ⊆ gameInputs adversary :=
+  (canonicalEncodingInputs_subset_gameInputs adversary parameter).trans Finset.subset_union_left
+
+theorem canonicalGraphInputs_subset_retainedGameInputs (adversary : Adversary) (parameter : PublicParameter) :
+    canonicalGraphInputs parameter ⊆ gameInputs adversary :=
+  (canonicalGraphInputs_subset_gameInputs adversary parameter).trans Finset.subset_union_left
+
+theorem boundaryInputs_subset_retainedGameInputs (adversary : Adversary) :
+    hashInputs (boundaryGameCore adversary) ⊆ gameInputs adversary :=
+  (hashInputs_subset_canonicalGraphGameInputs adversary).trans Finset.subset_union_left
+
+theorem boundaryGameCore_eq_retainedPrefixPrior (dummy : OtsReferenceWords) (adversary : Adversary) :
+    𝒟[(simulateQ romImpl (boundaryGameCore adversary)).run' ∅] =
+      Prod.snd <$> referencePrefixJointPriorGame (gameInputs adversary)
+        (canonicalEncodingInputs_subset_retainedGameInputs adversary) dummy adversary := by
+  rw [← referencePrefixCoordinateGame_eq_jointPrior, ← referenceResidualGame_eq_prefixCoordinates]
+  exact evalDist_boundaryGameCore_referenceResidual (gameInputs adversary)
+    (canonicalEncodingInputs_subset_retainedGameInputs adversary) (canonicalGraphInputs_subset_retainedGameInputs adversary)
+    dummy adversary (boundaryInputs_subset_retainedGameInputs adversary)
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualExceptionClassification.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualExceptionClassification.lean
new file mode 100644
index 000000000..738991097
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualExceptionClassification.lean
@@ -0,0 +1,79 @@
+import SphincsSecurity.Proof.Residual.RetainedResidualExceptionHistory
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs sourceInputs
+set_option backward.isDefEq.respectTransparency false
+
+variable (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+  (words : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+  (budget : Nat) (required : Finset FtsTree)
+
+theorem exceptionHistoryRun_unstopped {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : ExceptionHistoryState inputs) (hvalid : MonitoredValid inputs state.1)
+    (hinputs : sourceInputs key computation ⊆ inputs)
+    (hbefore : MonitoredAccounting state.1) (hbank : MonitoredBankComplete key required state.1)
+    (hsize : CacheSizeBound state.1.1.memory)
+    (hsigned : SigningDigestsCached key.parameter state.1.1.memory.external.cache key.root state.1.1.memory.log)
+    (halive : state.1.2.stopped = false) (hbudget : budget ≤ 2 ^ 127)
+    (result : Option Result × ExceptionHistoryState inputs)
+    (hresult : exceptionHistoryRun key inputs hencoding words publicReplies selections rows budget required
+      (proposalStop (fun _ _ _ _ => false)) computation state result ≠ 0)
+    (hlive : result.1 ≠ none) (hcost : result.2.1.1.memory.external.hashCalls ≤ budget)
+    (hlog : result.2.1.1.memory.log.length ≤ signatureLimit) (hclean : result.2.2 = (false, false)) :
+    result.2.1.2.stopped = false := by
+  let stop : CertificateStopRule := proposalStop (fun _ _ _ _ => false)
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value =>
+      rw [exceptionHistoryRun_pure] at hresult
+      simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact halive
+  | query_bind input next ih =>
+      have hwhole := exceptionHistoryRun_support key inputs hencoding words publicReplies selections rows budget required stop
+        (OracleSpec.query input >>= next) state result hresult
+      rw [exceptionHistoryRun_query_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨⟨answer, after⟩, hstep, hresult⟩ := hresult
+      cases answer with
+      | none =>
+          simp only [Option.elim_none, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          subst result
+          exact False.elim (hlive rfl)
+      | some answer =>
+          have hafter := exceptionHistoryRun_clean key inputs hencoding words publicReplies selections rows budget required stop
+            (next answer) after result hresult hclean
+          obtain ⟨hnativeStep, hupdate⟩ := exceptionHistoryStep_support key inputs hencoding words publicReplies selections rows budget required stop
+            input state (some answer, after) hstep
+          rw [hupdate] at hafter
+          simp only [exceptionHistoryUpdate, Prod.mk.injEq, Bool.or_eq_false_iff, decide_eq_false_iff_not] at hafter
+          have hin := (requestInputs_subset key input next).trans hinputs
+          have hnextInputs := (sourceInputs_next_subset key input next answer).trans hinputs
+          have hvalid' := monitoredStep_valid key inputs hencoding words publicReplies selections rows budget required stop
+            input state.1 hvalid (some answer, after.1) hnativeStep
+          have haccount' := (monitoredStep_accounting key inputs hencoding words publicReplies selections rows budget required stop
+            input state.1 hvalid hin hbefore (some answer, after.1) hnativeStep).1
+          have hnativeNext := exceptionHistoryRun_support key inputs hencoding words publicReplies selections rows budget required stop
+            (next answer) after result hresult
+          have hcost' := ((monitoredRun_accounting key inputs hencoding words publicReplies selections rows budget required stop
+            (next answer) after.1 hvalid' hnextInputs haccount' (result.1, result.2.1) hnativeNext).2.1).trans hcost
+          have hactive := monitoredRun_query_active key inputs hencoding words publicReplies selections rows budget required stop
+            input next state.1 hvalid hinputs hbefore hbank hsize hsigned (result.1, result.2.1) hwhole hcost hlog hbudget halive hafter.1.1.2
+          have hstop := monitoredStep_stopped_iff_prefix key inputs hencoding words publicReplies selections rows budget required
+            input state.1 hvalid hin hbefore hbank hsize hsigned hactive (some answer, after.1) hnativeStep
+            (by simp only [ne_eq, reduceCtorEq, not_false_eq_true]) hcost' hbudget hafter.1.2
+          have halive' : after.1.2.stopped = false := by
+            cases heq : after.1.2.stopped with
+            | false => rfl
+            | true => exact False.elim (hafter.2.2 (hstop.mp heq))
+          exact ih answer after hvalid' hnextInputs haccount'
+            (monitoredStep_bank_complete key inputs hencoding words publicReplies selections rows budget required stop
+              input state.1 hvalid.1 hbank (some answer, after.1) hnativeStep)
+            (monitoredStep_cacheSizeBound key inputs hencoding words publicReplies selections rows budget required stop
+              input state.1 hvalid hin hsize (some answer, after.1) hnativeStep)
+            (monitoredStep_digestsCached key inputs hencoding words publicReplies selections rows budget required stop
+              input state.1 hvalid hin hsigned (some answer, after.1) hnativeStep)
+            halive' hresult
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualExceptionGame.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualExceptionGame.lean
new file mode 100644
index 000000000..3d91ee29b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualExceptionGame.lean
@@ -0,0 +1,149 @@
+import SphincsSecurity.Proof.Residual.RetainedResidualExceptionClassification
+import SphincsSecurity.Proof.Residual.RetainedResidualMonitoredGame
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs sourceInputs gameInputs
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def initialExceptionHistorySource (key : SecretKey) (adversary : Adversary)
+    (encoding : ReferenceEncodingAuxiliary) (dummy : OtsReferenceWords)
+    (exposed : InitialPublicLabels (referenceFamilyWords encoding.selections dummy)) (high : CanonicalGraphHighHalves)
+    (budget : Nat) : SPMF (Option (Forgery × Bool) × ExceptionHistoryState (gameInputs adversary)) :=
+  exceptionHistoryRun key (gameInputs adversary) (canonicalEncodingInputs_subset_retainedGameInputs adversary key.parameter)
+    (referenceFamilyWords encoding.selections dummy)
+    (coordinateGraphLabels (initialKnown (referenceFamilyWords encoding.selections dummy) exposed) high)
+    encoding.selections encoding.rows budget Finset.univ (proposalStop (fun _ _ _ _ => false))
+    (FtsProbeSimulation.unloggedRetainedRestComputation adversary ⟨key.root, key.parameter⟩)
+    ((initialState (gameInputs adversary) (referenceFamilyWords encoding.selections dummy) exposed,
+      initialCertificateMonitor 1212415 false), (false, false))
+
+theorem initialExceptionHistorySource_erasure (key : SecretKey) (adversary : Adversary)
+    (encoding : ReferenceEncodingAuxiliary) (dummy : OtsReferenceWords)
+    (exposed : InitialPublicLabels (referenceFamilyWords encoding.selections dummy)) (high : CanonicalGraphHighHalves)
+    (budget : Nat) :
+    (fun result => (result.1, result.2.1)) <$> initialExceptionHistorySource key adversary encoding dummy exposed high budget =
+      initialMonitoredSource key adversary encoding dummy exposed high budget Finset.univ (proposalStop (fun _ _ _ _ => false)) false := by
+  exact exceptionHistoryRun_erasure _ _ _ _ _ _ _ _ _ _ _ _
+
+theorem initialExceptionHistorySource_exception (key : SecretKey) (adversary : Adversary)
+    (encoding : ReferenceEncodingAuxiliary) (dummy : OtsReferenceWords)
+    (exposed : InitialPublicLabels (referenceFamilyWords encoding.selections dummy)) (high : CanonicalGraphHighHalves)
+    (budget : Nat) (hparameter : key.parameter ∈ support sampleParameter)
+    (hencoding : encoding ∈ referenceEncodingAuxiliarySample.support)
+    (hroot : key.root = knownRoot (initialKnown (referenceFamilyWords encoding.selections dummy) exposed))
+    (hcost : HasHashQueryBound scheme adversary budget) (hbudget : budget ≤ 2 ^ 127)
+    (result : Option (Forgery × Bool) × ExceptionHistoryState (gameInputs adversary))
+    (hresult : initialExceptionHistorySource key adversary encoding dummy exposed high budget result ≠ 0)
+    (hexception : MonitoredStrongException (result.1, result.2.1)) :
+    result.2.2.1 = true ∨ result.2.2.2 = true := by
+  by_contra hflags
+  have hclean : result.2.2 = (false, false) := by
+    rcases hf : result.2.2 with ⟨cache, proposals⟩
+    cases cache <;> cases proposals <;> simp_all only [Bool.false_eq_true, or_self, not_false_eq_true, not_true_eq_false,
+      or_true, true_or]
+  obtain ⟨⟨value, hvalue, hwin⟩, hstop⟩ := hexception
+  have hlive : result.1 ≠ none := by rw [hvalue]; exact Option.some_ne_none _
+  have hlog : result.2.1.1.memory.log.length ≤ signatureLimit := by
+    simp only [sourceVerdict, Bool.and_eq_true, decide_eq_true_eq] at hwin
+    exact hwin.1.1
+  have hnative := map_nonzero _ (fun result => (result.1, result.2.1)) result hresult
+  rw [initialExceptionHistorySource_erasure] at hnative
+  have hbound := initialMonitoredSource_hashCalls_le key adversary encoding dummy exposed high budget Finset.univ
+    (proposalStop (fun _ _ _ _ => false)) false hparameter hencoding hroot hcost (result.1, result.2.1) hnative
+  have halive := exceptionHistoryRun_unstopped key (gameInputs adversary)
+    (canonicalEncodingInputs_subset_retainedGameInputs adversary key.parameter)
+    (referenceFamilyWords encoding.selections dummy)
+    (coordinateGraphLabels (initialKnown (referenceFamilyWords encoding.selections dummy) exposed) high)
+    encoding.selections encoding.rows budget Finset.univ _ _
+    ⟨initialAllowed_nonempty _ exposed, initialState_rowsCovered _ _ exposed⟩
+    (sourceInputs_unlogged_subset_gameInputs adversary key) (fun _ => rfl)
+    (monitoredBankComplete_initial key (gameInputs adversary) (referenceFamilyWords encoding.selections dummy) Finset.univ exposed 1212415 false)
+    (show CacheSizeBound (initialMemory (referenceFamilyWords encoding.selections dummy) exposed) from by
+      change QueryCache.enncard (∅ : QueryCache HashSpec) ≤ (1212415 : ENNReal)
+      rw [QueryCache.enncard_empty]
+      exact zero_le)
+    (by intro entry hentry; cases hentry) rfl hbudget result hresult hlive hbound hlog hclean
+  simp only [halive, Bool.false_eq_true] at hstop
+
+noncomputable def initialExceptionHistoryPrior (parameter : PublicParameter) (adversary : Adversary)
+    (encoding : ReferenceEncodingAuxiliary) (dummy : OtsReferenceWords)
+    (exposed : InitialPublicLabels (referenceFamilyWords encoding.selections dummy)) (high : CanonicalGraphHighHalves)
+    (budget : Nat) : SPMF (Option (Forgery × Bool) × ExceptionHistoryState (gameInputs adversary)) := do
+  let words := referenceFamilyWords encoding.selections dummy
+  let labels ← UniformTableCompletion.complete (initialAllowed words exposed)
+  let key : SecretKey := ⟨parameter, knownRoot (initialKnown words exposed), coordinateOtsSecrets labels, coordinateFtsSecrets labels⟩
+  initialExceptionHistorySource key adversary encoding dummy exposed high budget
+
+theorem initialExceptionHistoryPrior_erasure (parameter : PublicParameter) (adversary : Adversary)
+    (encoding : ReferenceEncodingAuxiliary) (dummy : OtsReferenceWords)
+    (exposed : InitialPublicLabels (referenceFamilyWords encoding.selections dummy)) (high : CanonicalGraphHighHalves)
+    (budget : Nat) :
+    (fun result => (result.1, result.2.1)) <$> initialExceptionHistoryPrior parameter adversary encoding dummy exposed high budget =
+      initialMonitoredPrior parameter adversary encoding dummy exposed high budget (fun _ _ _ _ => false) := by
+  simp only [initialExceptionHistoryPrior, initialMonitoredPrior, map_bind, initialExceptionHistorySource_erasure]
+
+noncomputable def exceptionHistorySourceGame (dummy : OtsReferenceWords) (adversary : Adversary)
+    (budget : Nat) : SPMF (Option (Forgery × Bool) × ExceptionHistoryState (gameInputs adversary)) := do
+  let parameter ← 𝒟[sampleParameter]
+  let encoding ← 𝒟[referenceEncodingAuxiliarySample]
+  let words := referenceFamilyWords encoding.selections dummy
+  let high ← 𝒟[PMF.uniformOfFintype CanonicalGraphHighHalves]
+  let exposed ← 𝒟[PMF.uniformOfFintype (InitialPublicLabels words)]
+  initialExceptionHistoryPrior parameter adversary encoding dummy exposed high budget
+
+theorem exceptionHistorySourceGame_erasure (dummy : OtsReferenceWords) (adversary : Adversary) (budget : Nat) :
+    (fun result => (result.1, result.2.1)) <$> exceptionHistorySourceGame dummy adversary budget =
+      monitoredSourceGame dummy adversary budget (fun _ _ _ _ => false) := by
+  simp only [exceptionHistorySourceGame, monitoredSourceGame, map_bind, initialExceptionHistoryPrior_erasure]
+
+theorem exceptionHistorySourceGame_exception (dummy : OtsReferenceWords) (adversary : Adversary)
+    (budget : Nat) (hcost : HasHashQueryBound scheme adversary budget) (hbudget : budget ≤ 2 ^ 127)
+    (result : Option (Forgery × Bool) × ExceptionHistoryState (gameInputs adversary))
+    (hresult : exceptionHistorySourceGame dummy adversary budget result ≠ 0)
+    (hexception : MonitoredStrongException (result.1, result.2.1)) :
+    result.2.2.1 = true ∨ result.2.2.2 = true := by
+  rw [exceptionHistorySourceGame, RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨parameter, hparameter, hresult⟩ := hresult
+  have hparameter' : parameter ∈ support sampleParameter := (mem_support_iff_evalDist_apply_ne_zero _ _).mpr hparameter
+  rw [RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨encoding, hencoding, hresult⟩ := hresult
+  have hencoding' : encoding ∈ referenceEncodingAuxiliarySample.support := by
+    apply (PMF.mem_support_iff _ _).mpr
+    simpa only [PMF.evalDist_eq, SPMF.liftM_apply] using hencoding
+  rw [RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨high, _, hresult⟩ := hresult
+  rw [RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨exposed, _, hresult⟩ := hresult
+  rw [initialExceptionHistoryPrior, RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨labels, _, hresult⟩ := hresult
+  exact initialExceptionHistorySource_exception _ adversary encoding dummy exposed high budget
+    hparameter' hencoding' rfl hcost hbudget result hresult hexception
+
+theorem monitoredSourceGame_exception_le_history (dummy : OtsReferenceWords) (adversary : Adversary)
+    (budget : Nat) (hcost : HasHashQueryBound scheme adversary budget) (hbudget : budget ≤ 2 ^ 127) :
+    Pr[MonitoredStrongException | monitoredSourceGame dummy adversary budget (fun _ _ _ _ => false)] ≤
+      Pr[fun result => result.2.2.1 = true | exceptionHistorySourceGame dummy adversary budget] +
+      Pr[fun result => result.2.2.2 = true | exceptionHistorySourceGame dummy adversary budget] := by
+  rw [← exceptionHistorySourceGame_erasure dummy adversary budget, probEvent_map]
+  apply le_trans ?_ (probEvent_or_le _ _ _)
+  apply probEvent_mono
+  intro result hsupport hexception
+  have hresult := probOutput_ne_zero_of_mem_support hsupport
+  rw [SPMF.probOutput_eq_apply] at hresult
+  exact exceptionHistorySourceGame_exception dummy adversary budget hcost hbudget result hresult hexception
+
+theorem forgeAdvantage_le_native_bound_add_histories (dummy : OtsReferenceWords)
+    (hdummy : ∀ lay tree leaf, TargetSum.Valid (dummy lay tree leaf)) (adversary : Adversary)
+    (budget : Nat) (hcost : HasHashQueryBound scheme adversary budget) (hbudget : budget ≤ 2 ^ 127) :
+    forgeAdvantage scheme adversary ≤
+      ENNReal.ofReal (2 * ((budget : ℝ) / 2 ^ digestBits) - ((budget : ℝ) / 2 ^ digestBits) ^ 2) +
+        (budget : ENNReal) * (11 / 2 ^ 144 : ENNReal) +
+        (Pr[fun result => result.2.2.1 = true | exceptionHistorySourceGame dummy adversary budget] +
+          Pr[fun result => result.2.2.2 = true | exceptionHistorySourceGame dummy adversary budget]) :=
+  (forgeAdvantage_le_monitored_bound_add_exception dummy hdummy adversary budget (fun _ _ _ _ => false) hcost hbudget).trans
+    (add_le_add le_rfl (monitoredSourceGame_exception_le_history dummy adversary budget hcost hbudget))
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualExceptionHistory.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualExceptionHistory.lean
new file mode 100644
index 000000000..f28258d25
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualExceptionHistory.lean
@@ -0,0 +1,118 @@
+import SphincsSecurity.Proof.Residual.RetainedResidualMonitorStops
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs sourceInputs
+set_option backward.isDefEq.respectTransparency false
+
+abbrev ExceptionHistoryState (inputs : Finset HashInput) := MonitoredState inputs × (Bool × Bool)
+
+noncomputable def exceptionHistoryUpdate {inputs : Finset HashInput} (key : SecretKey)
+    (before after : MonitoredState inputs) (history : Bool × Bool) : Bool × Bool :=
+  (history.1 || decide (CertificateCacheExceptional key before.1.memory.external.cache) ||
+    decide (CertificateCacheExceptional key after.1.memory.external.cache),
+   history.2 || decide (ProposalPrefixExceptional after.2.proposals after.2.log.length))
+
+variable (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+  (words : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+  (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+noncomputable def exceptionHistoryStep (input : (OracleWorld + SigningSpec).Domain) (state : ExceptionHistoryState inputs) :
+    SPMF (Option ((OracleWorld + SigningSpec).Range input) × ExceptionHistoryState inputs) :=
+  (fun result => (result.1, result.2, exceptionHistoryUpdate key state.1 result.2 state.2)) <$>
+    monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state.1
+
+noncomputable def exceptionHistoryRun {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : ExceptionHistoryState inputs) : SPMF (Option Result × ExceptionHistoryState inputs) :=
+  (simulateQ (fun input => OptionT.mk (StateT.mk
+    (exceptionHistoryStep key inputs hencoding words publicReplies selections rows budget required stopAfter input))) computation).run.run state
+
+theorem exceptionHistoryStep_erasure (input : (OracleWorld + SigningSpec).Domain) (state : ExceptionHistoryState inputs) :
+    (fun result => (result.1, result.2.1)) <$>
+      exceptionHistoryStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state =
+      monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state.1 := by
+  simp only [exceptionHistoryStep, Functor.map_map]
+  exact id_map _
+
+theorem exceptionHistoryStep_support (input : (OracleWorld + SigningSpec).Domain) (state : ExceptionHistoryState inputs)
+    (result : Option ((OracleWorld + SigningSpec).Range input) × ExceptionHistoryState inputs)
+    (hresult : exceptionHistoryStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state result ≠ 0) :
+    monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state.1 (result.1, result.2.1) ≠ 0 ∧
+      result.2.2 = exceptionHistoryUpdate key state.1 result.2.1 state.2 := by
+  obtain ⟨raw, hraw, heq⟩ := map_nonzero_source _ _ _ hresult
+  cases heq
+  exact ⟨hraw, rfl⟩
+
+theorem exceptionHistoryRun_pure {Result : Type} (value : Result) (state : ExceptionHistoryState inputs) :
+    exceptionHistoryRun key inputs hencoding words publicReplies selections rows budget required stopAfter (pure value) state =
+      pure (some value, state) := by
+  simp only [exceptionHistoryRun, simulateQ_pure, OptionT.run_pure, StateT.run_pure]
+
+theorem exceptionHistoryRun_query_bind {Result : Type} (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Result)
+    (state : ExceptionHistoryState inputs) :
+    exceptionHistoryRun key inputs hencoding words publicReplies selections rows budget required stopAfter
+      (liftM ((OracleWorld + SigningSpec).query input) >>= next) state =
+      (exceptionHistoryStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state >>= fun result =>
+        result.1.elim (pure (none, result.2)) fun answer =>
+          exceptionHistoryRun key inputs hencoding words publicReplies selections rows budget required stopAfter (next answer) result.2) := by
+  simp only [exceptionHistoryRun, simulateQ_bind, simulateQ_spec_query, OptionT.run_bind, Option.elimM, StateT.run_bind,
+    OptionT.run_mk, StateT.run_mk]
+  apply congrArg (_ >>= ·)
+  funext result
+  rcases result with ⟨answer, after⟩
+  cases answer <;> rfl
+
+theorem exceptionHistoryRun_erasure {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : ExceptionHistoryState inputs) :
+    (fun result => (result.1, result.2.1)) <$>
+      exceptionHistoryRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state =
+      monitoredRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state.1 := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [exceptionHistoryRun_pure, map_pure, monitoredRun_pure]
+  | query_bind input next ih =>
+      rw [exceptionHistoryRun_query_bind, map_bind, monitoredRun_query_bind,
+        ← exceptionHistoryStep_erasure key inputs hencoding words publicReplies selections rows budget required stopAfter input state,
+        bind_map_left]
+      apply RetainedObservation.bind_congr
+      rintro ⟨answer, after⟩ _
+      cases answer with
+      | none => simp only [Option.elim_none, map_pure]
+      | some answer => exact ih answer after
+
+theorem exceptionHistoryRun_support {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : ExceptionHistoryState inputs) (result : Option Result × ExceptionHistoryState inputs)
+    (hresult : exceptionHistoryRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state result ≠ 0) :
+    monitoredRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state.1 (result.1, result.2.1) ≠ 0 := by
+  have h := map_nonzero _ (fun result => (result.1, result.2.1)) result hresult
+  rwa [exceptionHistoryRun_erasure] at h
+
+theorem exceptionHistoryRun_clean {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : ExceptionHistoryState inputs) (result : Option Result × ExceptionHistoryState inputs)
+    (hresult : exceptionHistoryRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state result ≠ 0)
+    (hclean : result.2.2 = (false, false)) : state.2 = (false, false) := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value =>
+      rw [exceptionHistoryRun_pure] at hresult
+      simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact hclean
+  | query_bind input next ih =>
+      rw [exceptionHistoryRun_query_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨⟨answer, after⟩, hstep, hresult⟩ := hresult
+      have hafter : after.2 = (false, false) := by
+        cases answer with
+        | none =>
+            simp only [Option.elim_none, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+            subst result
+            exact hclean
+        | some answer => exact ih answer after hresult
+      have hupdate := (exceptionHistoryStep_support key inputs hencoding words publicReplies selections rows budget required stopAfter
+        input state (answer, after) hstep).2
+      rw [hupdate] at hafter
+      simp only [exceptionHistoryUpdate, Prod.mk.injEq, Bool.or_eq_false_iff, decide_eq_false_iff_not] at hafter
+      exact Prod.ext hafter.1.1.1 hafter.2.1
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualExecution.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualExecution.lean
new file mode 100644
index 000000000..1035b9a1e
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualExecution.lean
@@ -0,0 +1,173 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.InterleavedResidualDisclosure
+import SphincsSecurity.Proof.Ots.PrefixByteRun
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs
+set_option backward.isDefEq.respectTransparency false
+
+structure Memory where
+  external : ExternalMemory
+  routing : Routing
+  log : QueryLog SigningSpec
+  records : List (Message × SigningRecord)
+  messageCalls : List (HashInput × HashOutput)
+
+inductive Control (inputs : Finset HashInput) where
+  | byte (routing : Routing) (input : ResidualByteFrontend.Control inputs)
+  | routing
+  | transcript
+  | record (message : Message) (result : SigningRecord)
+
+abbrev ControlSpec (inputs : Finset HashInput) : OracleSpec (Control inputs)
+  | .byte _ input => ResidualByteFrontend.ControlSpec inputs input
+  | .routing => Routing
+  | .transcript => QueryLog SigningSpec
+  | .record _ _ => Unit
+
+abbrev World (inputs : Finset HashInput) := AdaptiveResidualLabels.World (ControlSpec inputs) CanonicalCoordinate inputs
+abbrev State (inputs : Finset HashInput) := AdaptiveResidualLabels.State CanonicalCoordinate inputs Memory
+
+def project {inputs : Finset HashInput} (state : State inputs) : ResidualByteFrontend.State inputs :=
+  ⟨state.candidates, state.rows, state.memory.external⟩
+
+def projectResult {Result : Type} {inputs : Finset HashInput} (result : Option Result × State inputs) :
+    Option Result × ResidualByteFrontend.State inputs := (result.1, project result.2)
+
+noncomputable def Memory.observeMessage (parameter : PublicParameter) (memory : Memory)
+    (input : HashInput) (answer : HashOutput) : Memory :=
+  if FtsProbeSimulation.MessageHashInput parameter input then
+    { memory with messageCalls := memory.messageCalls ++ [(input, answer)] }
+  else memory
+
+noncomputable def Memory.recordSigning (memory : Memory) (message : Message) (result : SigningRecord) : Memory :=
+  { memory with
+    routing := memory.routing.afterSigning result
+    log := memory.log ++ [⟨message, result.1.1⟩]
+    records := memory.records ++ [(message, result)] }
+
+def embed (inputs : Finset HashInput) (routing : Routing) :
+    QueryImpl (ResidualByteFrontend.World inputs) (OracleComp (World inputs))
+  | .inl input => liftM ((World inputs).query (.inl (.byte routing input)))
+  | .inr input => liftM ((World inputs).query (.inr input))
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+  (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+noncomputable def afterControl (memory : Memory) (input : ResidualByteFrontend.Control inputs)
+    (external : ExternalMemory) : Memory :=
+  let after := { memory with external := external }
+  match input with
+  | .prepare input => match memory.external.cache input.val with
+    | some answer => after.observeMessage parameter input.val answer
+    | none => after
+  | _ => after
+
+noncomputable def environment : AdaptiveResidualLabels.Environment (ControlSpec inputs) CanonicalCoordinate inputs Memory where
+  auxiliary state input := match input with
+    | .byte routing input =>
+        ((ResidualByteFrontend.prefixEnvironment parameter inputs hencoding words routing.disclosed routing.known
+          publicReplies selections rows).auxiliary (project state) input).map
+            (fun result => (result.1, afterControl parameter inputs state.memory input result.2))
+    | .routing => PMF.pure (some state.memory.routing, state.memory)
+    | .transcript => PMF.pure (some state.memory.log, state.memory)
+    | .record message result => PMF.pure (some (), state.memory.recordSigning message result)
+  rowAnswer memory input answer :=
+    ({ memory with external := storeReply memory.external input.val answer } : Memory).observeMessage parameter input.val answer
+  probeAnswer memory input _ answer :=
+    ({ memory with external := storeReply memory.external input.val answer } : Memory).observeMessage parameter input.val answer
+  probeStop memory _ _ := memory
+  disclosure memory _ _ := memory
+
+omit hencoding words publicReplies selections rows in
+theorem observeMessage_external (memory : Memory) (input : HashInput) (answer : HashOutput) :
+    (memory.observeMessage parameter input answer).external = memory.external := by
+  unfold Memory.observeMessage
+  split <;> rfl
+
+omit hencoding words publicReplies selections rows in
+theorem afterControl_external (memory : Memory) (input : ResidualByteFrontend.Control inputs) (external : ExternalMemory) :
+    (afterControl parameter inputs memory input external).external = external := by
+  cases input with
+  | prepare input =>
+      simp only [afterControl]
+      cases memory.external.cache input.val with
+      | none => rfl
+      | some answer => exact observeMessage_external parameter _ _ _
+  | random _ => rfl
+  | account _ => rfl
+  | stop => rfl
+
+theorem observedRun_embed_query (routing : Routing) (actual : Labels) (seed : inputs → HashOutput)
+    (input : (ResidualByteFrontend.World inputs).Domain) (state : State inputs) :
+    projectResult <$> observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+      (embed inputs routing input) state =
+      ((observedImpl (ResidualByteFrontend.prefixEnvironment parameter inputs hencoding words routing.disclosed routing.known
+        publicReplies selections rows) actual seed input).run).run (project state) := by
+  cases input with
+  | inl input =>
+      simp only [embed, observedRun, runWith, simulateQ_spec_query, observedImpl, environment,
+        OptionT.run_mk, StateT.run_mk, ← PMF.monad_map_eq_map, liftM_map, bind_map_left, map_bind, map_pure]
+      apply congrArg (_ >>= ·)
+      funext result
+      rcases result with ⟨answer, external⟩
+      simp only [projectResult, project, afterControl_external]
+  | inr input =>
+      simp only [embed, observedRun, runWith, simulateQ_spec_query]
+      cases input with
+      | read input =>
+          simp only [observedImpl, OptionT.run_mk, StateT.run_mk, map_pure, projectResult, project, readState,
+            environment, ResidualByteFrontend.environment, observeMessage_external]
+      | probe input test =>
+          simp only [observedImpl, OptionT.run_mk, StateT.run_mk]
+          cases hrow : state.rows input with
+          | some answer =>
+              simp only [project, hrow, map_pure, projectResult, readState, environment,
+                ResidualByteFrontend.environment, observeMessage_external]
+          | none =>
+              simp only [project, hrow]
+              split <;> simp only [map_pure, projectResult, project, probeState, stoppedState, environment,
+                ResidualByteFrontend.environment, observeMessage_external]
+      | disclose coordinate =>
+          simp only [observedImpl, OptionT.run_mk, StateT.run_mk, map_pure, projectResult, project, disclosedState,
+            environment, ResidualByteFrontend.environment]
+
+theorem observedRun_bind {A B : Type} (actual : Labels) (seed : inputs → HashOutput)
+    (computation : OracleComp (World inputs) A) (next : A → OracleComp (World inputs) B) (state : State inputs) :
+    observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+      (computation >>= next) state =
+      (observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed computation state >>= fun result =>
+        result.1.elim (pure (none, result.2)) (fun answer =>
+          observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed (next answer) result.2)) := by
+  simp only [observedRun, runWith, simulateQ_bind, OptionT.run_bind, Option.elimM, StateT.run_bind]
+  apply congrArg (_ >>= ·)
+  funext result
+  rcases result with ⟨answer, after⟩
+  cases answer <;> rfl
+
+theorem observedRun_embed {Result : Type} (routing : Routing) (actual : Labels) (seed : inputs → HashOutput)
+    (computation : OracleComp (ResidualByteFrontend.World inputs) Result) (state : State inputs) :
+    projectResult <$> observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+      (simulateQ (embed inputs routing) computation) state =
+      observedRun (ResidualByteFrontend.prefixEnvironment parameter inputs hencoding words routing.disclosed routing.known
+        publicReplies selections rows) actual seed computation (project state) := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [simulateQ_pure, observedRun, runWith_pure, map_pure, projectResult]
+  | query_bind input next ih =>
+      rw [simulateQ_bind, simulateQ_spec_query, observedRun_bind, map_bind]
+      conv_rhs => rw [observedRun, runWith_query_bind]
+      rw [← observedRun_embed_query parameter inputs hencoding words publicReplies selections rows routing actual seed input state]
+      simp only [bind_map_left]
+      apply congrArg (_ >>= ·)
+      funext result
+      rcases result with ⟨answer, after⟩
+      cases answer with
+      | none => simp only [Option.elim_none, map_pure, projectResult]
+      | some answer => exact ih answer after
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualGameTransfer.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualGameTransfer.lean
new file mode 100644
index 000000000..526fe78bc
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualGameTransfer.lean
@@ -0,0 +1,172 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualOriginalBudget
+import SphincsSecurity.Proof.Residual.RetainedResidualSuccessTransfer
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs sourceInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+  signDigestLoop signAfterDigest sequenceFin chainWalk gameInputs
+set_option backward.isDefEq.respectTransparency false
+
+theorem Context.frontierGame_original {inputs : Finset HashInput} (context : Context inputs)
+    (adversary : Adversary) (hroot : context.key.root = canonicalGraphRoot context.graph) :
+    Prod.fst <$> referenceFamilyFrontierRest context.key context.oracle context.graph
+        context.auxiliary.selections context.dummy adversary =
+      simulateQ (fixedHashWorld context.oracle)
+        (gameRest scheme adversary ⟨context.key.root, context.key.parameter⟩ context.key) := by
+  have hselection : referenceTableSelection context.key context.oracle = context.auxiliary.selections :=
+    referenceTableSelection_prefix context.key inputs context.encoding context.graph context.auxiliary context.auxiliary_valid
+  have hgraph : canonicalGraphLabels context.key.parameter context.key.otsSecret context.key.ftsSecret context.oracle =
+      context.graph := canonicalGraphLabels_programmedHash _ _ _ _ _
+  have hfrontier : referenceFamilyFrontierRest context.key context.oracle context.graph
+      context.auxiliary.selections context.dummy adversary =
+      fixedBoundaryRun context.key.parameter context.oracle
+        (gameAfterSecrets adversary context.key.parameter context.key.otsSecret context.key.ftsSecret) := by
+    rw [← hselection, referenceFamilyFrontierRest_selected, ← hgraph, graphFrontierGameRest_canonical]
+  rw [hfrontier, gameAfterSecrets, fixedBoundaryRun_bind, context.keygen_record hroot, pure_bind, Functor.map_map]
+  have hkey : (⟨context.key.parameter, context.key.root, context.key.otsSecret, context.key.ftsSecret⟩ : SecretKey) = context.key := by
+    cases context.key
+    rfl
+  change Prod.fst <$> fixedBoundaryRun context.key.parameter context.oracle
+    (gameRest scheme adversary ⟨context.key.root, context.key.parameter⟩
+      ⟨context.key.parameter, context.key.root, context.key.otsSecret, context.key.ftsSecret⟩) = _
+  rw [hkey, fixedBoundaryRun_forget]
+
+theorem forgeAdvantage_eq_retainedPrefixPrior (dummy : OtsReferenceWords) (adversary : Adversary) :
+    forgeAdvantage scheme adversary =
+      Pr[fun result => result.2.1 = true | referencePrefixJointPriorGame (gameInputs adversary)
+        (canonicalEncodingInputs_subset_retainedGameInputs adversary) dummy adversary] := by
+  have hgame : 𝒟[(simulateQ romImpl (gameCore scheme adversary)).run' ∅] =
+      (Prod.fst ∘ Prod.snd) <$> referencePrefixJointPriorGame (gameInputs adversary)
+        (canonicalEncodingInputs_subset_retainedGameInputs adversary) dummy adversary := by
+    rw [← boundaryGameCore_fst, simulateQ_map, StateT.run'_eq, StateT.run_map]
+    simp only [← LawfulFunctor.comp_map, Function.comp_def]
+    rw [evalDist_map]
+    have h := congrArg (fun law : SPMF (Bool × SigningBoundaryTrace) => Prod.fst <$> law)
+      (boundaryGameCore_eq_retainedPrefixPrior dummy adversary)
+    simpa only [StateT.run'_eq, evalDist_map, ← LawfulFunctor.comp_map, Function.comp_def] using h
+  rw [forgeAdvantage, probOutput_def, hgame]
+  change Pr[= true | (Prod.fst ∘ Prod.snd) <$> referencePrefixJointPriorGame (gameInputs adversary)
+    (canonicalEncodingInputs_subset_retainedGameInputs adversary) dummy adversary] = _
+  rw [probOutput_map]
+  rfl
+
+theorem observedInitialSource_success (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hcanonical : canonicalEncodingInputs parameter ⊆ inputs)
+    (encoding : ReferenceEncodingAuxiliary) (hencoding : encoding ∈ referenceEncodingAuxiliarySample.support)
+    (seed : inputs → HashOutput) (dummy : OtsReferenceWords)
+    (exposed : InitialPublicLabels (referenceFamilyWords encoding.selections dummy)) (high : CanonicalGraphHighHalves)
+    (labels : Labels)
+    (hlabels : UniformTableCompletion.complete (initialAllowed (referenceFamilyWords encoding.selections dummy) exposed) labels ≠ 0)
+    (adversary : Adversary)
+    (hinputs : ∀ key : SecretKey, sourceInputs key
+      (FtsProbeSimulation.unloggedRetainedRestComputation adversary ⟨key.root, key.parameter⟩) ⊆ inputs) :
+    Pr[fun result => result.1 = true |
+      referenceFamilyFrontierRest ⟨parameter, 0, coordinateOtsSecrets labels, coordinateFtsSecrets labels⟩
+        (programmedHash parameter (coordinateOtsSecrets labels) (coordinateFtsSecrets labels) (coordinateGraphLabels labels high)
+          (finiteHashAnswer ∅ inputs (canonicalPrefixResidual parameter inputs hcanonical (coordinateGraphLabels labels high)
+            encoding.selections encoding.rows seed)))
+        (coordinateGraphLabels labels high) encoding.selections dummy adversary] ≤
+      Pr[fun result => StoppedOr (fun value log => sourceVerdict value log = true) (forgetState result) |
+        observedRun
+          (environment parameter inputs hcanonical (referenceFamilyWords encoding.selections dummy)
+            (coordinateGraphLabels (initialKnown (referenceFamilyWords encoding.selections dummy) exposed) high)
+            encoding.selections encoding.rows)
+          labels seed
+          (simulateQ (adversaryImpl inputs parameter (knownRoot (initialKnown (referenceFamilyWords encoding.selections dummy) exposed))
+            (referenceFamilyWords encoding.selections dummy) encoding.selections)
+            (FtsProbeSimulation.unloggedRetainedRestComputation adversary
+              ⟨knownRoot (initialKnown (referenceFamilyWords encoding.selections dummy) exposed), parameter⟩))
+          (initialState inputs (referenceFamilyWords encoding.selections dummy) exposed)] := by
+  let auxiliary : ReferenceAuxiliary inputs := ⟨encoding.selections, encoding.rows, seed⟩
+  have hauxiliary := referenceEncodingAuxiliary_support_seed inputs encoding hencoding seed
+  let context := initialContext parameter inputs hcanonical auxiliary hauxiliary dummy exposed high labels
+  have hroot : context.key.root = canonicalGraphRoot context.graph :=
+    initialKnown_root (referenceFamilyWords encoding.selections dummy) exposed labels hlabels high
+  have hcompatible : Compatible context (initialState inputs (referenceFamilyWords encoding.selections dummy) exposed).memory := by
+    refine ⟨?_, ?_, ?_, ?_, ?_⟩
+    · simpa only [context, auxiliary, Context.words, Context.actual, initialContext, coordinateGraphLabels_value,
+        initialState, initialMemory] using initialKnown_agrees (referenceFamilyWords encoding.selections dummy) exposed labels hlabels
+    · exact initialKnown_graphReplies (referenceFamilyWords encoding.selections dummy) exposed labels hlabels high
+    · intro input answer hanswer; cases hanswer
+    · intro input answer hanswer; cases hanswer
+    · intro input answer hanswer; cases hanswer
+  have h := prob_gameRest_le_observed context adversary (hinputs context.key)
+    (initialState inputs (referenceFamilyWords encoding.selections dummy) exposed) (initialState_rowsCovered _ _ exposed)
+    hcompatible rfl
+  rw [← context.frontierGame_original adversary hroot, probEvent_map] at h
+  simpa only [context, auxiliary, Context.words, Context.actual, Context.oracle, Context.environment, initialContext,
+    coordinateGraphLabels_value, referenceFamilyFrontierRest, Function.comp_def] using h
+
+noncomputable def sourceGame (dummy : OtsReferenceWords) (adversary : Adversary) :
+    SPMF (Option (Forgery × Bool) × State (gameInputs adversary)) := do
+  let parameter ← 𝒟[sampleParameter]
+  let encoding ← 𝒟[referenceEncodingAuxiliarySample]
+  let words := referenceFamilyWords encoding.selections dummy
+  let high ← 𝒟[PMF.uniformOfFintype CanonicalGraphHighHalves]
+  let exposed ← 𝒟[PMF.uniformOfFintype (InitialPublicLabels words)]
+  lazyRun
+    (environment parameter (gameInputs adversary) (canonicalEncodingInputs_subset_retainedGameInputs adversary parameter)
+      words (coordinateGraphLabels (initialKnown words exposed) high) encoding.selections encoding.rows)
+    (simulateQ (adversaryImpl (gameInputs adversary) parameter (knownRoot (initialKnown words exposed)) words encoding.selections)
+      (FtsProbeSimulation.unloggedRetainedRestComputation adversary ⟨knownRoot (initialKnown words exposed), parameter⟩))
+    (initialState (gameInputs adversary) words exposed)
+
+private theorem probEvent_denotation {Result : Type} (computation : ProbComp Result) (event : Result → Prop) :
+    Pr[event | 𝒟[computation]] = Pr[event | computation] := rfl
+
+private theorem probEvent_bind_compare {A B C : Type} (law : SPMF A)
+    (left : A → SPMF B) (right : A → SPMF C) (before : B → Prop) (after : C → Prop)
+    (h : ∀ value, law value ≠ 0 → Pr[before | left value] ≤ Pr[after | right value]) :
+    Pr[before | law >>= left] ≤ Pr[after | law >>= right] := by
+  simp only [probEvent_bind_eq_tsum, SPMF.probOutput_eq_apply]
+  apply ENNReal.tsum_le_tsum
+  intro value
+  by_cases hvalue : law value = 0
+  · simp only [hvalue, zero_mul, le_refl]
+  exact mul_le_mul' le_rfl (h value hvalue)
+
+theorem forgeAdvantage_le_sourceGame (dummy : OtsReferenceWords) (adversary : Adversary) :
+    forgeAdvantage scheme adversary ≤
+      Pr[fun result => StoppedOr (fun value log => sourceVerdict value log = true) (forgetState result) |
+        sourceGame dummy adversary] := by
+  rw [forgeAdvantage_eq_retainedPrefixPrior dummy adversary]
+  rw [referencePrefixJointPriorGame, sourceGame]
+  apply probEvent_bind_compare
+  intro parameter _
+  apply probEvent_bind_compare
+  intro encoding hencoding
+  have hencoding' : encoding ∈ referenceEncodingAuxiliarySample.support := by
+    apply (PMF.mem_support_iff _ _).mpr
+    simpa only [PMF.evalDist_eq, SPMF.liftM_apply] using hencoding
+  apply probEvent_bind_compare
+  intro high _
+  apply probEvent_bind_compare
+  intro exposed _
+  rw [← run_erasure _ _ (initialState (gameInputs adversary) (referenceFamilyWords encoding.selections dummy) exposed)
+    (initialAllowed_nonempty _ exposed)]
+  apply probEvent_bind_compare
+  intro labels hlabels
+  apply probEvent_bind_compare
+  intro seed _
+  simp only [bind_pure_comp, probEvent_map, Function.comp_def, probEvent_denotation]
+  exact observedInitialSource_success parameter (gameInputs adversary)
+    (canonicalEncodingInputs_subset_retainedGameInputs adversary parameter) encoding hencoding' seed dummy exposed high labels
+    hlabels adversary (sourceInputs_unlogged_subset_gameInputs adversary)
+
+theorem forgeAdvantage_le_source_stop_add_win (dummy : OtsReferenceWords) (adversary : Adversary) :
+    forgeAdvantage scheme adversary ≤
+      Pr[fun result => result.1 = none | sourceGame dummy adversary] +
+        Pr[fun result => ∃ value, result.1 = some value ∧ sourceVerdict value result.2.memory.log = true |
+          sourceGame dummy adversary] := by
+  apply (forgeAdvantage_le_sourceGame dummy adversary).trans
+  apply le_trans _ (probEvent_or_le (sourceGame dummy adversary) _ _)
+  apply probEvent_mono
+  rintro ⟨result, state⟩ _ hresult
+  cases result with
+  | none => exact Or.inl rfl
+  | some value => exact Or.inr ⟨value, rfl, hresult⟩
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualHashTrace.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualHashTrace.lean
new file mode 100644
index 000000000..865933eb0
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualHashTrace.lean
@@ -0,0 +1,128 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.MessageByteTrace
+import SphincsSecurity.Proof.Residual.RetainedResidualExecution
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting ResidualByteAction
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def Memory.afterReply (parameter : PublicParameter) (memory : Memory) (input : HashInput)
+    (answer : Option HashOutput) (external : ExternalMemory) : Memory :=
+  answer.elim { memory with external := external }
+    (fun answer => ({ memory with external := external } : Memory).observeMessage parameter input answer)
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+  (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem freshPrefix_message (routing : Routing) (input : inputs)
+    (hmessage : FtsProbeSimulation.MessageHashInput parameter input.val) :
+    freshPrefix parameter inputs hencoding words routing.disclosed routing.known publicReplies selections rows input = .read input := by
+  have hdecode : decodePosition parameter input.val = none := by
+    obtain ⟨payload, heq⟩ := hmessage
+    rw [← heq]
+    exact decodePosition_message parameter payload
+  have hrow : knownEncodingRowAt parameter inputs hencoding routing.known input = none := by
+    apply (knownEncodingRowAt_none parameter inputs hencoding routing.known input).mpr
+    rintro ⟨row, hrow⟩
+    apply ResidualByteFrontend.message_not_encoding parameter input.val hmessage row.1
+    rw [← hrow]
+    exact ⟨_, rfl⟩
+  simp only [freshPrefix, route, hdecode, Option.elim_none, hrow]
+
+noncomputable def executeResult (actual : Labels) (seed : inputs → HashOutput) (state : State inputs) :
+    Action inputs → Option HashOutput × State inputs
+  | .known answer => (some answer, state)
+  | .read input => (some (seed input), readState (environment parameter inputs hencoding words publicReplies selections rows) state input (seed input))
+  | .probe input test =>
+      match state.rows input with
+      | some answer => (some answer, readState (environment parameter inputs hencoding words publicReplies selections rows) state input answer)
+      | none => if test.keep actual (seed input) then
+          (some (seed input), probeState (environment parameter inputs hencoding words publicReplies selections rows) state input test (seed input))
+        else (none, stoppedState (environment parameter inputs hencoding words publicReplies selections rows) state input test)
+
+theorem observedRun_execute (routing : Routing) (actual : Labels) (seed : inputs → HashOutput) (state : State inputs) (action : Action inputs) :
+    observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+      (simulateQ (embed inputs routing) (ResidualByteFrontend.execute action)) state =
+      pure (executeResult parameter inputs hencoding words publicReplies selections rows actual seed state action) := by
+  cases action with
+  | known answer => simp only [ResidualByteFrontend.execute, simulateQ_pure, observedRun, runWith_pure, executeResult]
+  | read input =>
+      simp only [ResidualByteFrontend.execute, simulateQ_spec_query, embed, observedRun, runWith, simulateQ_spec_query,
+        observedImpl, OptionT.run_mk, StateT.run_mk, executeResult]
+  | probe input test =>
+      simp only [ResidualByteFrontend.execute, simulateQ_spec_query, embed, observedRun, runWith, simulateQ_spec_query,
+        observedImpl, OptionT.run_mk, StateT.run_mk, executeResult]
+      dsimp only [OracleSpec.Range, World, AdaptiveResidualLabels.World, OracleSpec.add_apply_inr, ResidualSpec]
+      cases hrow : state.rows input with
+      | some answer => rfl
+      | none => by_cases hkeep : test.keep actual (seed input) <;> simp only [hkeep, if_true, if_false]
+
+noncomputable def prepareState (routing : Routing) (input : inputs) (state : State inputs) : Action inputs × State inputs :=
+  let prepared := ResidualByteFrontend.prepare parameter inputs words routing.disclosed routing.known
+    (freshPrefix parameter inputs hencoding words routing.disclosed routing.known publicReplies selections rows) input state.memory.external
+  (prepared.1, { state with memory := afterControl parameter inputs state.memory (.prepare input) prepared.2 })
+
+theorem observedRun_prepare_bind {Result : Type} (routing : Routing) (actual : Labels) (seed : inputs → HashOutput)
+    (input : inputs) (next : Action inputs → OracleComp (World inputs) Result) (state : State inputs) :
+    observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+      (embed inputs routing (.inl (.prepare input)) >>= next) state =
+      let prepared := prepareState parameter inputs hencoding words publicReplies selections rows routing input state
+      observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed (next prepared.1) prepared.2 := by
+  rw [embed, observedRun, runWith_query_bind]
+  simp only [observedImpl, environment, ResidualByteFrontend.environment, OptionT.run_mk, StateT.run_mk,
+    PMF.pure_map, SPMF.lift_pure, pure_bind, Option.elim_some, observedRun, prepareState, project]
+
+noncomputable def hashResult (routing : Routing) (actual : Labels) (seed : inputs → HashOutput) (input : inputs) (state : State inputs) :
+    Option HashOutput × State inputs :=
+  let prepared := prepareState parameter inputs hencoding words publicReplies selections rows routing input state
+  executeResult parameter inputs hencoding words publicReplies selections rows actual seed prepared.2 prepared.1
+
+theorem observedRun_hashQuery (routing : Routing) (actual : Labels) (seed : inputs → HashOutput) (input : inputs) (state : State inputs) :
+    observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+      (simulateQ (embed inputs routing) (ResidualByteFrontend.hashQuery input)) state =
+      pure (hashResult parameter inputs hencoding words publicReplies selections rows routing actual seed input state) := by
+  rw [ResidualByteFrontend.hashQuery, simulateQ_bind, simulateQ_spec_query, observedRun_prepare_bind, observedRun_execute]
+  rfl
+
+theorem hashResult_memory (routing : Routing) (actual : Labels) (seed : inputs → HashOutput) (input : inputs) (state : State inputs) :
+    let result := hashResult parameter inputs hencoding words publicReplies selections rows routing actual seed input state
+    result.2.memory = state.memory.afterReply parameter input.val result.1 result.2.memory.external := by
+  dsimp only
+  cases hcache : state.memory.external.cache input.val with
+  | some answer =>
+      simp only [hashResult, prepareState, ResidualByteFrontend.prepare, hcache, afterControl, executeResult,
+        Memory.afterReply, Option.elim_some, observeMessage_external]
+  | none =>
+      have hlocal := freshPrefix_local parameter inputs hencoding words routing.disclosed routing.known publicReplies selections rows input
+      cases haction : freshPrefix parameter inputs hencoding words routing.disclosed routing.known publicReplies selections rows input with
+      | known answer =>
+          have hnot : ¬FtsProbeSimulation.MessageHashInput parameter input.val := by
+            intro hmessage
+            have h := freshPrefix_message parameter inputs hencoding words publicReplies selections rows routing input hmessage
+            rw [haction] at h
+            cases h
+          simp only [hashResult, prepareState, ResidualByteFrontend.prepare, hcache, haction, afterControl, executeResult,
+            Memory.afterReply, Option.elim_some, Memory.observeMessage, if_neg hnot]
+      | read row =>
+          have heq : row = input := by simpa only [haction, Local] using hlocal
+          subst row
+          simp only [hashResult, prepareState, ResidualByteFrontend.prepare, hcache, haction, afterControl, executeResult,
+            Memory.afterReply, Option.elim_some, readState, environment, observeMessage_external]
+      | probe row test =>
+          have heq : row = input := by simpa only [haction, Local] using hlocal
+          subst row
+          simp only [hashResult, prepareState, ResidualByteFrontend.prepare, hcache, haction, afterControl, executeResult]
+          cases hrow : state.rows input with
+          | some answer =>
+              simp only [Memory.afterReply, Option.elim_some, readState, environment, observeMessage_external]
+          | none =>
+              by_cases hkeep : test.keep actual (seed input) <;>
+                simp only [hkeep, if_true, if_false, Memory.afterReply, Option.elim_some, Option.elim_none, probeState, stoppedState,
+                environment, observeMessage_external]
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualHazard.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualHazard.lean
new file mode 100644
index 000000000..53618a62f
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualHazard.lean
@@ -0,0 +1,38 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.ResidualByteCheckedHazard
+import SphincsSecurity.Proof.Residual.RetainedResidualCandidates
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec ENNReal CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing)
+open ResidualByteFrontend (HiddenCandidateBound probeHazard)
+attribute [local irreducible] hashInputs sourceInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+  (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem prob_checkedHashQuery_stop_le (routing : Routing) (input : inputs) (state : State inputs)
+    (hselect : ∀ position, FirstSuccessTable.select decodeEncodingOutput (fun counter => rows (position, counter)) = selections position)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hbound : HiddenCandidateBound words routing.disclosed (project state))
+    (hclean : ResidualByteFrontend.ReplyClean
+      (PublicEncodingMatch.Match parameter (knownEncodingMessage routing.known) words selections) state.memory.external.cache) :
+    Pr[fun result => result.1 = none |
+      lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+        (simulateQ (embed inputs routing)
+          (ResidualByteFrontend.checkedHashQuery (PublicEncodingMatch.Match parameter (knownEncodingMessage routing.known) words selections) input)) state] ≤
+      probeHazard state.memory.external.probes := by
+  have h := ResidualByteFrontend.prob_checkedPrefixHashQuery_stop_le parameter inputs words routing.disclosed routing.known hencoding
+    publicReplies selections rows hselect input (project state) ha hcovered hbound hclean
+  rw [← lazyRun_embed_project parameter inputs hencoding words publicReplies selections rows routing _ state ha] at h
+  simpa only [probEvent_map, Function.comp_def, projectResult, project] using h
+
+variable (key : SecretKey) (adversary : Adversary) (encoding : ReferenceEncodingAuxiliary) (dummy : OtsReferenceWords)
+  (exposed : InitialPublicLabels (referenceFamilyWords encoding.selections dummy)) (high : CanonicalGraphHighHalves)
+  (q : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule) (stopped : Bool)
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualHistory.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualHistory.lean
new file mode 100644
index 000000000..08335d1a4
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualHistory.lean
@@ -0,0 +1,98 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualProgram
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs
+set_option backward.isDefEq.respectTransparency false
+
+def Memory.history (memory : Memory) := (memory.routing, memory.log, memory.records)
+
+theorem observeMessage_history (parameter : PublicParameter) (memory : Memory) (input : HashInput) (answer : HashOutput) :
+    (memory.observeMessage parameter input answer).history = memory.history := by
+  unfold Memory.observeMessage
+  split <;> rfl
+
+theorem afterControl_history (parameter : PublicParameter) (inputs : Finset HashInput)
+    (memory : Memory) (input : ResidualByteFrontend.Control inputs) (external : ExternalMemory) :
+    (afterControl parameter inputs memory input external).history = memory.history := by
+  cases input with
+  | prepare input =>
+      simp only [afterControl]
+      cases memory.external.cache input.val with
+      | none => rfl
+      | some answer => exact observeMessage_history parameter _ _ _
+  | random _ => rfl
+  | account _ => rfl
+  | stop => rfl
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+  (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem observedRun_embed_query_history (routing : Routing) (actual : Labels) (seed : inputs → HashOutput)
+    (input : (ResidualByteFrontend.World inputs).Domain) (state : State inputs)
+    (result : Option ((ResidualByteFrontend.World inputs).Range input) × State inputs)
+    (hresult : observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+      (embed inputs routing input) state result ≠ 0) : result.2.memory.history = state.memory.history := by
+  cases input with
+  | inl input =>
+      simp only [embed, observedRun, runWith, simulateQ_spec_query, observedImpl, environment,
+        OptionT.run_mk, StateT.run_mk, ← PMF.monad_map_eq_map, liftM_map, bind_map_left] at hresult
+      obtain ⟨after, _, hresult⟩ := (RetainedObservation.bind_nonzero _ _ _).mp hresult
+      simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact afterControl_history parameter inputs state.memory input after.2
+  | inr input =>
+      simp only [embed, observedRun, runWith, simulateQ_spec_query] at hresult
+      cases input with
+      | read input =>
+          simp only [observedImpl, OptionT.run_mk, StateT.run_mk, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          subst result
+          exact observeMessage_history parameter _ _ _
+      | probe input test =>
+          simp only [observedImpl, OptionT.run_mk, StateT.run_mk] at hresult
+          cases hrow : state.rows input with
+          | some answer =>
+              simp only [hrow, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+              subst result
+              exact observeMessage_history parameter _ _ _
+          | none =>
+              simp only [hrow] at hresult
+              split at hresult
+              all_goals
+                simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+                subst result
+              · exact observeMessage_history parameter _ _ _
+              · rfl
+      | disclose coordinate =>
+          simp only [observedImpl, OptionT.run_mk, StateT.run_mk, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          subst result
+          rfl
+
+theorem observedRun_embed_history {Result : Type} (routing : Routing) (actual : Labels) (seed : inputs → HashOutput)
+    (computation : OracleComp (ResidualByteFrontend.World inputs) Result) (state : State inputs)
+    (result : Option Result × State inputs)
+    (hresult : observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+      (simulateQ (embed inputs routing) computation) state result ≠ 0) : result.2.memory.history = state.memory.history := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value =>
+      simp only [simulateQ_pure, observedRun, runWith_pure, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      rfl
+  | query_bind input next ih =>
+      rw [simulateQ_bind, simulateQ_spec_query, observedRun_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨⟨answer, after⟩, hafter, hresult⟩ := hresult
+      have hhistory := observedRun_embed_query_history parameter inputs hencoding words publicReplies selections rows
+        routing actual seed input state (answer, after) hafter
+      cases answer with
+      | none =>
+          simp only [Option.elim_none, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          subst result
+          exact hhistory
+      | some answer => exact (ih answer after hresult).trans hhistory
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualInitial.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualInitial.lean
new file mode 100644
index 000000000..ac5ffbe63
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualInitial.lean
@@ -0,0 +1,81 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualBudget
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting UniformTableCompletion
+open AdaptiveResidualLabels hiding World State Environment
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs sourceInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def initialMemory (words : OtsReferenceWords) (exposedValues : InitialPublicLabels words) : Memory :=
+  ⟨⟨fun _ => none, 1212415, 0⟩, ⟨fun _ _ _ => False, initialKnown words exposedValues⟩, [], [], []⟩
+
+noncomputable def initialState (inputs : Finset HashInput) (words : OtsReferenceWords)
+    (exposedValues : InitialPublicLabels words) : State inputs :=
+  ⟨initialAllowed words exposedValues, fun _ => none, initialMemory words exposedValues⟩
+
+noncomputable def initialContext (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (auxiliary : ReferenceAuxiliary inputs)
+    (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support) (dummy : OtsReferenceWords)
+    (exposedValues : InitialPublicLabels (referenceFamilyWords auxiliary.selections dummy))
+    (high : CanonicalGraphHighHalves) (labels : Labels) : Context inputs where
+  key := ⟨parameter, knownRoot (initialKnown (referenceFamilyWords auxiliary.selections dummy) exposedValues),
+    coordinateOtsSecrets labels, coordinateFtsSecrets labels⟩
+  graph := coordinateGraphLabels labels high
+  auxiliary := auxiliary
+  encoding := hencoding
+  auxiliary_valid := hauxiliary
+  dummy := dummy
+  publicReplies := coordinateGraphLabels (initialKnown (referenceFamilyWords auxiliary.selections dummy) exposedValues) high
+
+theorem initialState_rowsCovered (inputs : Finset HashInput) (words : OtsReferenceWords)
+    (exposedValues : InitialPublicLabels words) : ResidualByteFrontend.RowsCovered inputs (project (initialState inputs words exposedValues)) := by
+  intro input answer hanswer
+  cases hanswer
+
+theorem Context.keygen_record {inputs : Finset HashInput} (context : Context inputs)
+    (hroot : context.key.root = canonicalGraphRoot context.graph) :
+    fixedBoundaryRun context.key.parameter context.oracle
+      (liftM (treeRoot context.key.parameter topLayer rootTree (context.key.otsSecret topLayer rootTree) : OracleComp HashSpec Digest)) =
+        pure (context.key.root, (FreeMonoid.of none) ^ 1212415) := by
+  have hcomputed : context.key.root = evalWithAnswerFn context.oracle
+      (treeRoot context.key.parameter topLayer rootTree (context.key.otsSecret topLayer rootTree)) := by
+    rw [hroot, ← canonicalGraphLabels_root context.key.parameter context.key.otsSecret context.key.ftsSecret context.oracle]
+    congr 1
+    exact (canonicalGraphLabels_programmedHash context.key.parameter context.key.otsSecret context.key.ftsSecret context.graph _).symm
+  rw [fixedBoundaryRun_lift_hash]
+  have htree : boundaryEval context.key.parameter context.oracle
+      (treeRoot context.key.parameter topLayer rootTree (context.key.otsSecret topLayer rootTree)) =
+      (evalWithAnswerFn context.oracle (treeRoot context.key.parameter topLayer rootTree (context.key.otsSecret topLayer rootTree)),
+        (FreeMonoid.of none) ^ 1212415) :=
+    boundaryEval_treeNode context.key.parameter context.oracle topLayer rootTree (context.key.otsSecret topLayer rootTree) _ _
+  rw [htree, ← hcomputed]
+
+theorem Context.rest_queryBound {inputs : Finset HashInput} (context : Context inputs)
+    (hroot : context.key.root = canonicalGraphRoot context.graph)
+    (hparameter : context.key.parameter ∈ support sampleParameter) (adversary : Adversary) (q : Nat)
+    (hq : HasHashQueryBound scheme adversary q) :
+    1212415 ≤ q ∧ (gameRest scheme adversary ⟨context.key.root, context.key.parameter⟩ context.key).IsQueryBoundP
+      (· matches .inr _) (q - 1212415) := by
+  have hots : context.key.otsSecret ∈ support sampleOtsSecrets := by
+    unfold sampleOtsSecrets
+    exact otsSecretsSampleableType.mem_support_selectElem _
+  have hfts : context.key.ftsSecret ∈ support sampleFtsSecrets := by
+    unfold sampleFtsSecrets
+    exact ftsSecretsSampleableType.mem_support_selectElem _
+  have hbound := isQueryBoundP_gameAfterSecrets adversary q hq hparameter hots hfts
+  rw [gameAfterSecrets] at hbound
+  have hresult : 𝒟[fixedBoundaryRun context.key.parameter context.oracle
+      (liftM (treeRoot context.key.parameter topLayer rootTree (context.key.otsSecret topLayer rootTree) : OracleComp HashSpec Digest))]
+        (context.key.root, (FreeMonoid.of none) ^ 1212415) ≠ 0 := by
+    rw [context.keygen_record hroot, evalDist_pure, SPMF.pure_apply_self]
+    exact one_ne_zero
+  have h := fixedBoundaryRun_bind_query_bound context.key.parameter context.oracle _ _ q hbound _ hresult
+  have hkey : (⟨context.key.parameter, context.key.root, context.key.otsSecret, context.key.ftsSecret⟩ : SecretKey) = context.key := by
+    cases context.key
+    rfl
+  simp only [SigningBoundaryTrace.hashCalls_pow_none, hkey] at h
+  exact h
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMessageKernel.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMessageKernel.lean
new file mode 100644
index 000000000..60357e542
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMessageKernel.lean
@@ -0,0 +1,141 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Ots.PrefixEncodingRisk
+import SphincsSecurity.Proof.Residual.RetainedResidualHashTrace
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting ResidualByteAction
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def messageState (parameter : PublicParameter) {inputs : Finset HashInput}
+    (state : State inputs) (input : inputs) (answer : HashOutput) : State inputs :=
+  let external := storeReply { state.memory.external with hashCalls := state.memory.external.hashCalls + 1 } input.val answer
+  ⟨state.candidates,
+    if state.memory.external.cache input.val = none then Function.update state.rows input (some answer) else state.rows,
+    ({ state.memory with external := external } : Memory).observeMessage
+        parameter input.val answer⟩
+
+theorem messageState_cache (parameter : PublicParameter) {inputs : Finset HashInput}
+    (state : State inputs) (input : inputs) (answer : HashOutput) :
+    (messageState parameter state input answer).memory.external.cache =
+      Function.update state.memory.external.cache input.val (some answer) := by
+  simp only [messageState, observeMessage_external, storeReply]
+
+theorem messageState_rowsCovered (parameter : PublicParameter) {inputs : Finset HashInput}
+    (state : State inputs) (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (input : inputs) (answer : HashOutput)
+    (hanswer : state.memory.external.cache input.val = none ∨ state.memory.external.cache input.val = some answer) :
+    ResidualByteFrontend.RowsCovered inputs (project (messageState parameter state input answer)) := by
+  intro other output hrow
+  change (messageState parameter state input answer).memory.external.cache other.val = some output
+  rw [messageState_cache]
+  change (if state.memory.external.cache input.val = none then Function.update state.rows input (some answer)
+    else state.rows) other = some output at hrow
+  rcases hanswer with hfresh | hcached
+  · rw [if_pos hfresh] at hrow
+    by_cases heq : other = input
+    · subst other
+      rw [Function.update_self, Option.some.injEq] at hrow
+      subst output
+      exact Function.update_self ..
+    · rw [Function.update_of_ne heq] at hrow
+      rw [Function.update_of_ne (fun h => heq (Subtype.ext h))]
+      exact hcovered other output hrow
+  · rw [if_neg (by rw [hcached]; simp)] at hrow
+    rw [← hcached, Function.update_eq_self]
+    exact hcovered other output hrow
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+  (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem lazyRun_prepare_bind {Result : Type} (routing : Routing)
+    (input : inputs) (next : Action inputs → OracleComp (World inputs) Result) (state : State inputs) :
+    lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+      (embed inputs routing (.inl (.prepare input)) >>= next) state =
+      let prepared := prepareState parameter inputs hencoding words publicReplies selections rows routing input state
+      lazyRun (environment parameter inputs hencoding words publicReplies selections rows) (next prepared.1) prepared.2 := by
+  rw [embed, lazyRun, runWith_query_bind]
+  simp only [lazyImpl, environment, ResidualByteFrontend.environment, OptionT.run_mk, StateT.run_mk,
+    PMF.pure_map, SPMF.lift_pure, pure_bind, Option.elim_some, lazyRun, prepareState, project]
+
+theorem lazyRun_hashQuery_message (routing : Routing) (input : inputs)
+    (hmessage : FtsProbeSimulation.MessageHashInput parameter input.val) (state : State inputs)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) :
+    lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+      (simulateQ (embed inputs routing) (ResidualByteFrontend.hashQuery input)) state =
+      (fun result => (some result.1, messageState parameter state input result.1)) <$>
+        𝒟[(randomOracle (spec := HashSpec) input.val).run state.memory.external.cache] := by
+  have hdecode : decodePosition parameter input.val = none := by
+    obtain ⟨payload, heq⟩ := hmessage
+    rw [← heq]
+    exact decodePosition_message parameter payload
+  rw [ResidualByteFrontend.hashQuery, simulateQ_bind, simulateQ_spec_query, lazyRun_prepare_bind]
+  cases hcache : state.memory.external.cache input.val with
+  | some answer =>
+      rw [randomOracle, QueryImpl.withCaching_run_some _ hcache]
+      simp only [prepareState, ResidualByteFrontend.prepare, hcache, afterControl, ResidualByteFrontend.execute,
+        simulateQ_pure, lazyRun, runWith_pure, evalDist_pure, map_pure, messageState,
+        reduceCtorEq, if_false, charge, Nat.add_zero]
+      congr 2
+      unfold storeReply
+      rw [← hcache, Function.update_eq_self]
+  | none =>
+      have hrow := ResidualByteFrontend.rowsCovered_fresh inputs (project state) hcovered input hcache
+      change state.rows input = none at hrow
+      rw [randomOracle, QueryImpl.withCaching_run_none _ hcache]
+      simp only [prepareState, ResidualByteFrontend.prepare, hcache,
+        freshPrefix_message parameter inputs hencoding words publicReplies selections rows routing input hmessage,
+        afterControl, ResidualByteFrontend.execute, simulateQ_spec_query, embed, lazyRun, runWith,
+        simulateQ_spec_query, lazyImpl, OptionT.run_mk, StateT.run_mk, ResidualTableCompletion.reply,
+        hrow, readState, environment, messageState, if_true, charge, route, hdecode,
+        Option.elim_none, Nat.add_zero]
+      simp only [uniformSampleImpl, map_eq_bind_pure_comp, evalDist_bind, evalDist_pure,
+        evalDist_uniformSample, bind_assoc, Function.comp_apply, pure_bind]
+
+theorem checkedHashQuery_message (routing : Routing) (input : inputs)
+    (hmessage : FtsProbeSimulation.MessageHashInput parameter input.val) :
+    ResidualByteFrontend.checkedHashQuery
+      (PublicEncodingMatch.Match parameter (knownEncodingMessage routing.known) words selections) input =
+      ResidualByteFrontend.hashQuery input := by
+  have hreject (answer : HashOutput) :
+      ¬PublicEncodingMatch.Match parameter (knownEncodingMessage routing.known) words selections input.val answer := by
+    rintro ⟨position, hat, _⟩
+    exact ResidualByteFrontend.message_not_encoding parameter input.val hmessage position hat
+  simp only [ResidualByteFrontend.checkedHashQuery, hreject, if_false, bind_pure]
+
+theorem randomOracle_messageState (state : State inputs)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) (input : inputs)
+    (result : HashOutput × QueryCache HashSpec)
+    (hresult : result ∈ support ((randomOracle input.val).run state.memory.external.cache)) :
+    (messageState parameter state input result.1).memory.external.cache = result.2 ∧
+      ResidualByteFrontend.RowsCovered inputs (project (messageState parameter state input result.1)) := by
+  cases hcache : state.memory.external.cache input.val with
+  | none =>
+      rw [randomOracle, QueryImpl.withCaching_run_none _ hcache, support_map] at hresult
+      obtain ⟨answer, _, rfl⟩ := hresult
+      exact ⟨messageState_cache parameter state input answer,
+        messageState_rowsCovered parameter state hcovered input answer (Or.inl hcache)⟩
+  | some answer =>
+      rw [randomOracle, QueryImpl.withCaching_run_some _ hcache, support_pure, Set.mem_singleton_iff] at hresult
+      subst result
+      constructor
+      · rw [messageState_cache, ← hcache, Function.update_eq_self]
+      · exact messageState_rowsCovered parameter state hcovered input answer (Or.inr hcache)
+
+theorem lazyRun_bind {A B : Type} (computation : OracleComp (World inputs) A)
+    (next : A → OracleComp (World inputs) B) (state : State inputs) :
+    lazyRun (environment parameter inputs hencoding words publicReplies selections rows) (computation >>= next) state =
+      (lazyRun (environment parameter inputs hencoding words publicReplies selections rows) computation state >>= fun result =>
+        result.1.elim (pure (none, result.2)) (fun answer =>
+          lazyRun (environment parameter inputs hencoding words publicReplies selections rows) (next answer) result.2)) := by
+  simp only [lazyRun, runWith, simulateQ_bind, OptionT.run_bind, Option.elimM, StateT.run_bind]
+  apply congrArg (_ >>= ·)
+  funext result
+  rcases result with ⟨answer, after⟩
+  cases answer <;> rfl
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMessagePayment.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMessagePayment.lean
new file mode 100644
index 000000000..443878d53
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMessagePayment.lean
@@ -0,0 +1,255 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CertificateMessagePayment
+import SphincsSecurity.Proof.Residual.RetainedResidualMonitoredPayment
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec ENNReal CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing SigningRecord)
+open FtsProbeSimulation (MessageHashInput messageHashCharge)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs sourceInputs
+  signDigestLoop publicSignPlan
+set_option backward.isDefEq.respectTransparency false
+
+private theorem expected_evalDist {Result : Type} (computation : ProbComp Result) (weight : Result → ENNReal) :
+    (∑' result, Pr[= result | 𝒟[computation]] * weight result) =
+      ∑' result, Pr[= result | computation] * weight result := rfl
+
+theorem digestWork_messageCalls (known : Labels) (words : OtsReferenceWords) (selections : ReferenceFamily)
+    (selected : Option (Randomness × Index × (IndexGroup → FtsLeaf)) × SigningBoundaryTrace) :
+    (digestWork known words selections selected).1.2.messageCalls = selected.2.messageCalls := by
+  rcases selected with ⟨selected, trace⟩
+  cases selected <;> simp only [digestWork, SigningBoundaryTrace.messageCalls_mul,
+    SigningBoundaryTrace.messageCalls_pow_none, List.append_nil]
+
+theorem expected_publicSigningWork_messageCalls (key : SecretKey) (known : Labels) (words : OtsReferenceWords)
+    (selections : ReferenceFamily) (message : Message) (cache : QueryCache HashSpec) :
+    (∑' result, Pr[= result | (simulateQ romImpl
+        (ResidualByteFrontend.publicSigningWork key.parameter key.root known words selections message)).run cache] *
+      result.1.1.2.messageCalls.length) = digestAttemptExpectation digestAttemptLimit key message cache := by
+  rw [publicSigningWork_eq_digestWork, simulateQ_map, StateT.run_map, tsum_probOutput_map_mul]
+  simp only [digestWork_messageCalls]
+  rw [publicDigestLoop_eq, simulateQ_boundaryComputation]
+  exact (expectedBoundaryMessageCalls_eq_queryCharge key.parameter (signDigestLoop digestAttemptLimit key message) cache).trans
+    (expectedQueryCharge_signDigestLoop_message digestAttemptLimit key message cache)
+
+theorem targetCreationMultiplier_sign_le_digestAttempts (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) :
+    targetCreationMultiplier key cache (.inr message) ≤ digestAttemptExpectation digestAttemptLimit key message cache := by
+  have h := probEvent_signDigestLoop_fresh_le_attempts_mul_admissibility digestAttemptLimit key message cache cache
+    (onlyRejectedNewMessageEntries_self cache key message)
+  have hs := mul_le_mul' (le_refl (((2 ^ ftsTreeHeight : Nat) : ENNReal))) h
+  have hc : (((2 ^ ftsTreeHeight : Nat) : ENNReal) *
+      (digestAttemptExpectation digestAttemptLimit key message cache * ((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹)) =
+      digestAttemptExpectation digestAttemptLimit key message cache := by
+    rw [mul_left_comm, ENNReal.mul_inv_cancel (by norm_num [ftsTreeHeight]) (by finiteness), mul_one]
+  rw [hc] at hs
+  exact hs
+
+private theorem expected_signing_cache_messageCalls {inputs : Finset HashInput}
+    (native : SPMF (Option SigningRecord × State inputs))
+    (candidates : CanonicalCoordinate → Finset Digest)
+    (ha : ∀ coordinate, (candidates coordinate).Nonempty)
+    (work : ProbComp ((PublicSigningRecord × Nat) × QueryCache HashSpec)) (expected : ENNReal)
+    (hwork : (∑' result, Pr[= result | work] * result.1.1.2.messageCalls.length) = expected)
+    (hkernel : cacheResult <$> native =
+      (UniformTableCompletion.complete candidates >>= fun actual =>
+        (fun result => (some (completePublicSigningRecord (fun index tree leaf => actual (.ftsStart index tree leaf)) result.1.1), result.2)) <$>
+          𝒟[work])) :
+    (∑' result, Pr[= result | native] * result.1.elim 0 (fun record => (record.2.messageCalls.length : ENNReal))) = expected := by
+  have h := congrArg (fun law : SPMF (Option SigningRecord × QueryCache HashSpec) =>
+    ∑' result, Pr[= result | law] * result.1.elim 0 (fun record => (record.2.messageCalls.length : ENNReal))) hkernel
+  rw [tsum_probOutput_map_mul, tsum_probOutput_bind_mul] at h
+  simp only [tsum_probOutput_map_mul, Option.elim_some, completePublicSigningRecord_trace, expected_evalDist, cacheResult] at h
+  have hm : (∑' actual, Pr[= actual | UniformTableCompletion.complete candidates]) = 1 := by
+    rw [UniformTableCompletion.complete_of_nonempty candidates ha]
+    simp only [SPMF.probOutput_eq_apply, SPMF.liftM_apply, PMF.tsum_coe]
+  rw [hwork, ENNReal.tsum_mul_right, hm, one_mul] at h
+  exact h
+
+variable (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+  (words : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+attribute [local irreducible] lazyRun environment ResidualByteFrontend.jointSigningProgram
+
+theorem expected_lazySigning_messageCalls (message : Message) (state : State inputs)
+    (hinputs : requestInputs key (.inr message) ⊆ inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) :
+    (∑' result, Pr[= result | lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+        (simulateQ (embed inputs state.memory.routing)
+          (ResidualByteFrontend.jointSigningProgram inputs key.parameter key.root state.memory.routing.known words selections message)) state] *
+      result.1.elim 0 (fun record => (record.2.messageCalls.length : ENNReal))) =
+      digestAttemptExpectation digestAttemptLimit key message state.memory.external.cache := by
+  have hin := digestInputs_of_request key inputs words selections message state.memory.routing.known hinputs
+  exact expected_signing_cache_messageCalls _ state.candidates ha _ _
+    (expected_publicSigningWork_messageCalls key state.memory.routing.known words selections message state.memory.external.cache)
+    (lazyRun_jointSigningProgram_cache key.parameter inputs hencoding words publicReplies selections rows state.memory.routing
+      key.root message (by simpa only [publicDigestLoop_eq] using hin) state ha hcovered)
+
+noncomputable def monitoredMessageCharge (key : SecretKey) (budget : Nat)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState) : ENNReal :=
+  if CertificateMonitorActive key budget input state then
+    match input with
+    | .inl world => hashQueryCharge (messageHashCharge key.parameter) state.1 world
+    | .inr message => digestAttemptExpectation digestAttemptLimit key message state.1
+  else 0
+
+theorem certificateMonitorMass_le_monitoredMessageCharge (key : SecretKey) (budget : Nat)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState) :
+    certificateMonitorMass key budget input state ≤ monitoredMessageCharge key budget input state := by
+  by_cases ha : CertificateMonitorActive key budget input state
+  · rw [certificateMonitorMass, monitoredMessageCharge.eq_def, if_pos ha, if_pos ha]
+    cases input with
+    | inl world =>
+        exact (targetCreationMultiplier_le_expected_messageCalls key (.inl world) state.1).trans_eq
+          (expected_originalProposalRecord_world_messageCalls key world state.1)
+    | inr message => exact targetCreationMultiplier_sign_le_digestAttempts key message state.1
+  · simp only [certificateMonitorMass, monitoredMessageCharge.eq_def, if_neg ha, le_refl]
+
+variable (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+attribute [local irreducible] certificateMonitorUpdate certificateMonitorCharge certificateMonitorMass
+  monitorView monitoredSigningResult monitoredMessageCharge
+
+theorem monitoredStep_world_messageCalls (input : OracleWorld.Domain) (state : MonitoredState inputs)
+    (hinputs : requestInputs key (.inl input) ⊆ inputs)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state.1))
+    (result : Option (OracleWorld.Range input) × MonitoredState inputs)
+    (hresult : monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter (.inl input) state result ≠ 0) :
+    (result.2.2.messageCalls : ENNReal) = state.2.messageCalls + monitoredMessageCharge key budget (.inl input) (monitorView state) := by
+  rw [monitoredStep, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨raw, hraw, hresult⟩ := hresult
+  simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+  subst result
+  by_cases hn : raw.1 = none
+  · have hz := (stopped_world_message_charges_zero key inputs hencoding words publicReplies selections rows input state hinputs hcovered raw hraw hn).2
+    have hc : monitoredMessageCharge key budget (.inl input) (monitorView state) = 0 := by
+      unfold monitoredMessageCharge monitorView
+      simp only [hz, ite_self]
+    simp only [monitoredWorldResult, hn, Option.elim_none, hc, add_zero]
+  · obtain ⟨answer, ha⟩ := Option.ne_none_iff_exists'.mp hn
+    simp only [monitoredWorldResult, ha, Option.elim_some]
+    by_cases hactive : CertificateMonitorActive key budget (.inl input) (monitorView state)
+    · rw [certificateMonitorUpdate_messageCalls _ _ _ _ _ _ _ _ hactive, Nat.cast_add]
+      simp only [proposalOfWorldResult, signingBoundaryTrace_messageCalls key.parameter input answer state.1.memory.external.cache,
+        monitoredMessageCharge.eq_def, if_pos hactive]
+      simp only [monitorView]
+    · rw [certificateMonitorUpdate_inactive _ _ _ _ _ _ _ _ hactive]
+      simp only [monitoredMessageCharge.eq_def, if_neg hactive, add_zero]
+      simp only [monitorView]
+
+theorem monitoredSigningResult_messageCalls (message : Message) (annotation : Nat × Index)
+    (state : MonitoredState inputs) (raw : Option SigningRecord × State inputs) :
+    ((monitoredSigningResult key budget required stopAfter message annotation state raw).2.2.messageCalls : ENNReal) =
+      state.2.messageCalls + if CertificateMonitorActive key budget (.inr message) (monitorView state) then
+        raw.1.elim 0 (fun record => (record.2.messageCalls.length : ENNReal)) else 0 := by
+  rcases raw with ⟨answer, after⟩
+  cases answer with
+  | none => simp only [monitoredSigningResult, Option.elim_none, ite_self, add_zero]
+  | some record =>
+      simp only [monitoredSigningResult, Option.elim_some]
+      by_cases ha : CertificateMonitorActive key budget (.inr message) (monitorView state)
+      · rw [certificateMonitorUpdate_messageCalls _ _ _ _ _ _ _ _ ha, Nat.cast_add, if_pos ha]
+        simp only [monitorView, proposalOfSigningRecord]
+      · rw [certificateMonitorUpdate_inactive _ _ _ _ _ _ _ _ ha, if_neg ha, add_zero]
+        simp only [monitorView]
+
+private theorem tsum_eq_one_of_bind_const {Result : Type} (law : SPMF Result)
+    (h : (law >>= fun _ => (pure () : SPMF Unit)) = pure ()) :
+    (∑' result, Pr[= result | law]) = 1 := by
+  have hh := congrArg (fun law : SPMF Unit => Pr[= () | law]) h
+  simpa only [probOutput_bind_eq_tsum, probOutput_pure_self, mul_one] using hh
+
+private theorem expected_signing_step_messageCalls (message : Message) (state : MonitoredState inputs)
+    (law : SPMF (Option SigningRecord × State inputs)) (hm : (∑' result, Pr[= result | law]) = 1)
+    (hmessage : (∑' result, Pr[= result | law] * result.1.elim 0 (fun record => (record.2.messageCalls.length : ENNReal))) =
+      digestAttemptExpectation digestAttemptLimit key message state.1.memory.external.cache) :
+    (∑' result, Pr[= result |
+      ((liftM (signingAnnotation key budget message (monitorView state)) : SPMF _) >>= fun annotation =>
+        monitoredSigningResult key budget required stopAfter message annotation state <$> law)] * result.2.2.messageCalls) =
+      state.2.messageCalls + monitoredMessageCharge key budget (.inr message) (monitorView state) := by
+  have hmannotation : (∑' annotation, Pr[= annotation | (liftM (signingAnnotation key budget message (monitorView state)) : SPMF _)]) = 1 := by
+    simp only [SPMF.probOutput_eq_apply, SPMF.liftM_apply, PMF.tsum_coe]
+  have hc : monitoredMessageCharge key budget (.inr message) (monitorView state) =
+      if CertificateMonitorActive key budget (.inr message) (monitorView state) then
+        digestAttemptExpectation digestAttemptLimit key message state.1.memory.external.cache else 0 := by
+    unfold monitoredMessageCharge monitorView
+    rfl
+  rw [hc, tsum_probOutput_bind_mul]
+  simp only [tsum_probOutput_map_mul, monitoredSigningResult_messageCalls]
+  by_cases ha : CertificateMonitorActive key budget (.inr message) (monitorView state)
+  · simp only [if_pos ha, mul_add, ENNReal.tsum_add, ENNReal.tsum_mul_right, hm, one_mul, hmessage, hmannotation]
+  · simp only [if_neg ha, add_zero, ENNReal.tsum_mul_right, hm, hmannotation, one_mul]
+
+theorem expected_monitoredStep_messageCalls (input : (OracleWorld + SigningSpec).Domain)
+    (state : MonitoredState inputs) (hvalid : MonitoredValid inputs state)
+    (hinputs : requestInputs key input ⊆ inputs) :
+    (∑' result, Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+      result.2.2.messageCalls) = state.2.messageCalls + monitoredMessageCharge key budget input (monitorView state) := by
+  cases input with
+  | inl input =>
+      calc
+        _ = ∑' result, Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter (.inl input) state] *
+            ((state.2.messageCalls : ENNReal) + monitoredMessageCharge key budget (.inl input) (monitorView state)) := by
+          apply tsum_congr
+          intro result
+          by_cases hr : Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter (.inl input) state] = 0
+          · simp only [hr, zero_mul]
+          · rw [SPMF.probOutput_eq_apply] at hr
+            rw [monitoredStep_world_messageCalls key inputs hencoding words publicReplies selections rows budget required stopAfter
+              input state hinputs hvalid.2 result hr]
+        _ = _ := by
+          rw [ENNReal.tsum_mul_right, tsum_monitoredStep_eq_one key inputs hencoding words publicReplies selections rows
+            budget required stopAfter (.inl input) state hvalid.1, one_mul]
+  | inr message =>
+      rw [monitoredStep]
+      apply expected_signing_step_messageCalls key inputs budget required stopAfter message state
+      · apply tsum_eq_one_of_bind_const
+        exact lazyRun_bind_const (environment key.parameter inputs hencoding words publicReplies selections rows)
+          (simulateQ (embed inputs state.1.memory.routing)
+            (ResidualByteFrontend.jointSigningProgram inputs key.parameter key.root state.1.memory.routing.known words selections message))
+          state.1 hvalid.1 (pure ())
+      · exact expected_lazySigning_messageCalls key inputs hencoding words publicReplies selections rows message state.1 hinputs hvalid.1 hvalid.2
+
+theorem expected_monitoredStep_creationMass (input : (OracleWorld + SigningSpec).Domain)
+    (state : MonitoredState inputs) (hvalid : MonitoredValid inputs state)
+    (hinputs : requestInputs key input ⊆ inputs) :
+    (∑' result, Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+      result.2.2.creationMass) = state.2.creationMass + certificateMonitorMass key budget input (monitorView state) := by
+  calc
+    _ = ∑' result, Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+        (state.2.creationMass + certificateMonitorMass key budget input (monitorView state)) := by
+      apply tsum_congr
+      intro result
+      by_cases hr : Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] = 0
+      · simp only [hr, zero_mul]
+      · rw [SPMF.probOutput_eq_apply] at hr
+        rw [(monitoredStep_creation_counters key inputs hencoding words publicReplies selections rows budget required stopAfter
+          input state hvalid hinputs result hr).2]
+    _ = _ := by
+      rw [ENNReal.tsum_mul_right, tsum_monitoredStep_eq_one key inputs hencoding words publicReplies selections rows
+        budget required stopAfter input state hvalid.1, one_mul]
+
+theorem expected_monitoredRun_creationMass_le_messageCalls {Result : Type}
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) (state : State inputs) (spent : Nat) (stopped : Bool)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hinputs : sourceInputs key computation ⊆ inputs) :
+    (∑' result, Pr[= result | monitoredRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation
+        (state, initialCertificateMonitor spent stopped)] * result.2.2.creationMass) ≤
+      ∑' result, Pr[= result | monitoredRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation
+        (state, initialCertificateMonitor spent stopped)] * result.2.2.messageCalls := by
+  rw [expected_monitoredRun_accumulator key inputs hencoding words publicReplies selections rows budget required stopAfter
+      CertificateMonitor.creationMass (certificateMonitorMass key budget)
+      (expected_monitoredStep_creationMass key inputs hencoding words publicReplies selections rows budget required stopAfter)
+      computation (state, initialCertificateMonitor spent stopped) ⟨ha, hcovered⟩ hinputs,
+    expected_monitoredRun_accumulator key inputs hencoding words publicReplies selections rows budget required stopAfter
+      (fun monitor => (monitor.messageCalls : ENNReal)) (monitoredMessageCharge key budget)
+      (expected_monitoredStep_messageCalls key inputs hencoding words publicReplies selections rows budget required stopAfter)
+      computation (state, initialCertificateMonitor spent stopped) ⟨ha, hcovered⟩ hinputs]
+  simp only [initialCertificateMonitor, Nat.cast_zero, zero_add]
+  exact expectedMonitoredPayment_mono key inputs hencoding words publicReplies selections rows budget required stopAfter
+    _ _ (certificateMonitorMass_le_monitoredMessageCharge key budget) computation _
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMessageTrace.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMessageTrace.lean
new file mode 100644
index 000000000..884840902
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMessageTrace.lean
@@ -0,0 +1,82 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualByteRun
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def Memory.applyBoundary (memory : Memory) (trace : SigningBoundaryTrace) : Memory :=
+  { memory with
+    external := ResidualByteFrontend.applyBoundary memory.external trace
+    messageCalls := memory.messageCalls ++ trace.messageCalls }
+
+theorem applyBoundary_one (memory : Memory) : memory.applyBoundary 1 = memory := by
+  simp only [Memory.applyBoundary, ResidualByteFrontend.applyBoundary_one,
+    show SigningBoundaryTrace.messageCalls 1 = [] from rfl, List.append_nil]
+
+theorem applyBoundary_mul (memory : Memory) (left right : SigningBoundaryTrace) :
+    memory.applyBoundary (left * right) = (memory.applyBoundary left).applyBoundary right := by
+  simp only [Memory.applyBoundary, ResidualByteFrontend.applyBoundary_mul, SigningBoundaryTrace.messageCalls_mul, List.append_assoc]
+
+theorem fixedHashStep_message (parameter : PublicParameter) (words : OtsReferenceWords) (selections : ReferenceFamily)
+    (routing : Routing) (actual : Labels) (oracle : QueryImpl HashSpec Id) (input : HashInput)
+    (hmessage : FtsProbeSimulation.MessageHashInput parameter input) (memory : Memory) :
+    fixedHashStep parameter words selections routing actual oracle input memory =
+      (some (oracle input), memory.applyBoundary (signingBoundaryTrace parameter (.inr input) (oracle input))) := by
+  rw [fixedHashStep, ResidualByteFrontend.checkedFixedStep_message parameter words routing.disclosed routing.known actual
+    (knownEncodingMessage routing.known) selections oracle input hmessage memory.external]
+  simp only [ResidualByteFrontend.messageStep, Memory.afterReply, Option.elim_some, Memory.observeMessage,
+    Memory.applyBoundary,
+    signingBoundaryTrace, if_pos hmessage]
+  rfl
+
+theorem fixedByteRun_message_trace {Result : Type} (parameter : PublicParameter) (words : OtsReferenceWords) (selections : ReferenceFamily)
+    (routing : Routing) (actual : Labels) (oracle : QueryImpl HashSpec Id)
+    (computation : OracleComp OracleWorld Result) (hmessage : ResidualByteFrontend.MessageOnly parameter computation) (memory : Memory) :
+    fixedByteRun parameter words selections routing actual oracle computation memory =
+      (fun result => (some result.1, memory.applyBoundary result.2)) <$> 𝒟[fixedBoundaryRun parameter oracle computation] := by
+  induction computation using OracleComp.inductionOn generalizing memory with
+  | pure value => simp only [fixedByteRun_pure, fixedBoundaryRun_pure, evalDist_pure, map_pure, applyBoundary_one]
+  | query_bind input next ih =>
+      have hnext : ∀ answer, ResidualByteFrontend.MessageOnly parameter (next answer) :=
+        fun answer row hrow => hmessage row ((hashInputs_next_subset input next answer) hrow)
+      rw [fixedByteRun_query_bind, ResidualByteFrontend.fixedBoundaryRun_query_bind]
+      cases input with
+      | inl input =>
+          simp only [fixedByteImpl, OptionT.run_mk, StateT.run_mk, fixedHashWorld, evalDist_bind,
+            evalDist_query, signingBoundaryTrace, one_mul, evalDist_map, bind_assoc, pure_bind, Option.elim_some, map_bind]
+          apply congrArg (_ >>= ·)
+          funext answer
+          simpa only [Functor.map_map, Function.comp_def] using ih answer (hnext answer) memory
+      | inr input =>
+          have hat := hmessage input (mem_hashInputs_hash_bind input next)
+          simp only [fixedByteImpl, OptionT.run_mk, StateT.run_mk,
+            fixedHashStep_message parameter words selections routing actual oracle input hat,
+            fixedHashWorld, pure_bind, Option.elim_some, evalDist_map, Functor.map_map]
+          rw [ih (oracle input) (hnext (oracle input))]
+          congr 1
+          funext result
+          rw [applyBoundary_mul]
+
+theorem byteRun_message_trace {Result : Type} (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+    (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+    (routing : Routing) (actual : Labels) (seed : inputs → HashOutput) (oracle : QueryImpl HashSpec Id)
+    (hfresh : ∀ input : inputs, ResidualByteAction.eval actual seed
+      (ResidualByteAction.freshPrefix parameter inputs hencoding words routing.disclosed routing.known publicReplies selections rows input) =
+      ResidualByteFrontend.fixedAnswer parameter words routing.disclosed actual oracle input.val)
+    (computation : OracleComp OracleWorld Result) (hinputs : hashInputs computation ⊆ inputs)
+    (hmessage : ResidualByteFrontend.MessageOnly parameter computation) (state : State inputs)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hmatches : ResidualByteFrontend.CacheMatches oracle state.memory.external.cache)
+    (hclean : CacheClean parameter words routing.disclosed actual state.memory.external.cache) :
+    forgetState <$> byteRun parameter inputs hencoding words publicReplies selections rows routing actual seed computation state =
+      (fun result => (some result.1, state.memory.applyBoundary result.2)) <$> 𝒟[fixedBoundaryRun parameter oracle computation] := by
+  rw [byteRun_eq_fixed parameter inputs hencoding words publicReplies selections rows routing actual seed oracle hfresh
+    computation hinputs state hcovered hmatches hclean, fixedByteRun_message_trace parameter words selections routing actual oracle computation hmessage]
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMonitorReadiness.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMonitorReadiness.lean
new file mode 100644
index 000000000..ec9c9cb3c
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMonitorReadiness.lean
@@ -0,0 +1,131 @@
+import SphincsSecurity.Proof.Residual.RetainedResidualCacheAccounting
+import SphincsSecurity.Proof.Residual.RetainedResidualProposalSupport
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (SigningRecord)
+open FtsProbeSimulation (messageAnswers MessageHashInput)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs sourceInputs
+  signDigestLoop signAfterDigest
+set_option backward.isDefEq.respectTransparency false
+
+variable (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+  (words : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem lazyWorld_digestsCached (input : OracleWorld.Domain) (state : State inputs)
+    (hinputs : hashInputs (liftM (OracleWorld.query input)) ⊆ inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (log : QueryLog SigningSpec) (hsigned : SigningDigestsCached key.parameter state.memory.external.cache key.root log)
+    (result : Option (OracleWorld.Range input) × State inputs)
+    (hresult : lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+      (externalProgram inputs key.parameter words selections (liftM (OracleWorld.query input))) state result ≠ 0) :
+    SigningDigestsCached key.parameter result.2.memory.external.cache key.root log := by
+  rw [lazyRun_externalProgram] at hresult
+  by_cases hmessage : ∀ hash, input = .inr hash → MessageHashInput key.parameter hash
+  · have h := map_nonzero _ cacheResult result hresult
+    rw [lazyByteRun_world_message_rom key.parameter inputs hencoding words publicReplies selections rows
+      state.memory.routing input hinputs hmessage state hcovered] at h
+    obtain ⟨source, hsource, heq⟩ := map_nonzero_source _ _ _ h
+    have hcache : result.2.memory.external.cache = source.2 := congrArg Prod.snd heq
+    rw [hcache]
+    apply hsigned.mono
+    apply simulateQ_romImpl_cache_le (liftM (OracleWorld.query input)) state.memory.external.cache source
+    simpa only [simulateQ_spec_query] using (mem_support_iff_evalDist_apply_ne_zero _ _).mpr hsource
+  · cases input with
+    | inl sample => exact False.elim (hmessage (by intro hash h; cases h))
+    | inr input =>
+        have hm : ¬MessageHashInput key.parameter input := fun h => hmessage (by intro hash heq; cases heq; exact h)
+        have hin : input ∈ inputs := hinputs (by
+          simpa only [bind_pure] using mem_hashInputs_hash_bind input pure)
+        unfold SigningDigestsCached
+        rw [lazyByteRun_hash_nonmessage key.parameter inputs hencoding words publicReplies selections rows
+          state.memory.routing input hin state ha hcovered hm result hresult]
+        exact hsigned
+
+theorem lazySigning_digestsCached (message : Message) (state : State inputs)
+    (hinputs : hashInputs (signDigestLoop digestAttemptLimit key message) ⊆ inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (log : QueryLog SigningSpec) (hsigned : SigningDigestsCached key.parameter state.memory.external.cache key.root log)
+    (result : Option SigningRecord × State inputs)
+    (hresult : lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+      (simulateQ (embed inputs state.memory.routing)
+        (ResidualByteFrontend.jointSigningProgram inputs key.parameter key.root state.memory.routing.known words selections message)) state result ≠ 0) :
+    ∃ record, result.1 = some record ∧
+      SigningDigestsCached key.parameter result.2.memory.external.cache key.root (log ++ [⟨message, record.1.1⟩]) := by
+  obtain ⟨record, loop, hrecord, hloop, hcache, hcompletion⟩ :=
+    lazySigning_digestRecord key inputs hencoding words publicReplies selections rows message state hinputs ha hcovered result hresult
+  have hle := simulateQ_romImpl_cache_le _ _ _ hloop
+  rw [← hcache] at hle
+  refine ⟨record, hrecord, ?_⟩
+  intro entry hentry signature hsignature
+  rcases List.mem_append.mp hentry with hold | hnew
+  · exact (hsigned.mono hle) entry hold signature hsignature
+  · obtain rfl := List.mem_singleton.mp hnew
+    obtain ⟨output, houtput, _, _⟩ := digestCompletion_successful_cached_output key message state.memory.external.cache
+      loop hloop (record.1, result.2.memory.external.cache) hcompletion signature hsignature
+    exact Option.ne_none_iff_exists'.mpr ⟨output, houtput⟩
+
+variable (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+theorem monitoredStep_digestsCached (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState inputs)
+    (hvalid : MonitoredValid inputs state) (hinputs : requestInputs key input ⊆ inputs)
+    (hsigned : SigningDigestsCached key.parameter state.1.memory.external.cache key.root state.1.memory.log)
+    (result : Option ((OracleWorld + SigningSpec).Range input) × MonitoredState inputs)
+    (hresult : monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state result ≠ 0) :
+    SigningDigestsCached key.parameter result.2.1.memory.external.cache key.root result.2.1.memory.log := by
+  cases input with
+  | inl input =>
+      rw [monitoredStep, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨raw, hraw, hresult⟩ := hresult
+      simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      have hlog := lazyRun_externalProgram_log key inputs hencoding words publicReplies selections rows _ state.1 hvalid.1 raw hraw
+      change SigningDigestsCached key.parameter raw.2.memory.external.cache key.root raw.2.memory.log
+      rw [hlog]
+      exact lazyWorld_digestsCached key inputs hencoding words publicReplies selections rows input state.1 hinputs hvalid.1 hvalid.2
+        state.1.memory.log hsigned raw hraw
+  | inr message =>
+      rw [monitoredStep, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨annotation, _, hresult⟩ := hresult
+      rw [map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨raw, hraw, hresult⟩ := hresult
+      simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      have hin := digestInputs_of_request key inputs words selections message state.1.memory.routing.known hinputs
+      obtain ⟨record, hr, hcached⟩ := lazySigning_digestsCached key inputs hencoding words publicReplies selections rows message state.1
+        hin hvalid.1 hvalid.2 state.1.memory.log hsigned raw hraw
+      have hlog := lazyRun_embed_log key inputs hencoding words publicReplies selections rows _ _ state.1 hvalid.1 raw hraw
+      have heq : raw = (some record, raw.2) := Prod.ext hr rfl
+      rw [heq]
+      change SigningDigestsCached key.parameter raw.2.memory.external.cache key.root (raw.2.memory.log ++ [⟨message, record.1.1⟩])
+      rwa [hlog]
+
+theorem monitoredRun_query_active {Result : Type} (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Result)
+    (state : MonitoredState inputs) (hvalid : MonitoredValid inputs state)
+    (hinputs : sourceInputs key (OracleSpec.query input >>= next) ⊆ inputs)
+    (hbefore : MonitoredAccounting state) (hbank : MonitoredBankComplete key required state)
+    (hsize : CacheSizeBound state.1.memory)
+    (hsigned : SigningDigestsCached key.parameter state.1.memory.external.cache key.root state.1.memory.log)
+    (result : Option Result × MonitoredState inputs)
+    (hresult : monitoredRun key inputs hencoding words publicReplies selections rows budget required stopAfter
+      (OracleSpec.query input >>= next) state result ≠ 0)
+    (hcost : result.2.1.memory.external.hashCalls ≤ budget) (hlog : result.2.1.memory.log.length ≤ signatureLimit)
+    (hbudget : budget ≤ 2 ^ 127) (halive : state.2.stopped = false)
+    (hclean : ¬ CertificateCacheExceptional key state.1.memory.external.cache) :
+    CertificateMonitorActive key budget input (monitorView state) := by
+  obtain ⟨hvalidStep, hmacro⟩ := monitoredRun_query_conditions key inputs hencoding words publicReplies selections rows budget required stopAfter
+    input next state hvalid hinputs hbefore hbank result hresult hcost hlog halive
+  have htotal := ((monitoredRun_accounting key inputs hencoding words publicReplies selections rows budget required stopAfter
+    (OracleSpec.query input >>= next) state hvalid hinputs hbefore result hresult).2.1).trans hcost
+  have hcache := proposalCacheBound_of_no_cache_exception key _ (Finite.of_enncard_le hsize) _ (htotal.trans hbudget) hsize hclean
+  rw [← hbefore halive] at hcache htotal
+  refine ⟨halive, ⟨?_, hcache, htotal⟩, hvalidStep, hmacro⟩
+  change SigningDigestsCached key.parameter state.1.memory.external.cache key.root state.2.log
+  rwa [(hbank halive).1]
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMonitorStops.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMonitorStops.lean
new file mode 100644
index 000000000..abae80873
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMonitorStops.lean
@@ -0,0 +1,144 @@
+import SphincsSecurity.Proof.Residual.RetainedResidualMonitorReadiness
+import SphincsSecurity.Proof.Residual.RetainedResidualProposalInvariant
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs sourceInputs
+  signDigestLoop signAfterDigest
+set_option backward.isDefEq.respectTransparency false
+
+variable (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+  (words : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+  (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+theorem monitoredStep_record (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState inputs)
+    (hvalid : MonitoredValid inputs state) (hinputs : requestInputs key input ⊆ inputs)
+    (result : Option ((OracleWorld + SigningSpec).Range input) × MonitoredState inputs)
+    (hresult : monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state result ≠ 0)
+    (hlive : result.1 ≠ none) :
+    ∃ (length : Nat) (record : ProposalExecutionRecord input), result.1 = some record.output ∧
+      result.2.2 = certificateMonitorUpdate key budget required stopAfter input (monitorView state) length record ∧
+      record.cache = result.2.1.memory.external.cache ∧
+      result.2.1.memory.log = (proposalRecordLogState input state.1.memory.log record).2 ∧
+      result.2.1.memory.external.hashCalls = state.1.memory.external.hashCalls + record.trace.hashCalls := by
+  cases input with
+  | inl input =>
+      rw [monitoredStep, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨raw, hraw, hresult⟩ := hresult
+      simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      have hlog := lazyRun_externalProgram_log key inputs hencoding words publicReplies selections rows _ state.1 hvalid.1 raw hraw
+      rw [lazyRun_externalProgram] at hraw
+      have hhash := lazyByteRun_world_hashCalls key.parameter inputs hencoding words publicReplies selections rows state.1.memory.routing
+        input hinputs state.1 hvalid.1 raw hraw
+      cases hr : raw.1 with
+      | none => exact False.elim (hlive hr)
+      | some answer =>
+          refine ⟨0, proposalOfWorldResult key.parameter input (answer, raw.2.memory.external.cache), ?_, ?_, rfl, ?_, ?_⟩
+          · exact hr
+          · simp only [monitoredWorldResult, hr, Option.elim_some]
+          · simpa only [monitoredWorldResult, proposalRecordLogState, signingLogFragment, List.append_nil] using hlog
+          · change raw.2.memory.external.hashCalls = state.1.memory.external.hashCalls + (signingBoundaryTrace key.parameter input answer).hashCalls
+            rw [signingBoundaryTrace_hashCalls_eq]
+            cases input <;> exact hhash
+  | inr message =>
+      rw [monitoredStep, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨annotation, _, hresult⟩ := hresult
+      rw [map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨raw, hraw, hresult⟩ := hresult
+      simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      have hin := digestInputs_of_request key inputs words selections message state.1.memory.routing.known hinputs
+      obtain ⟨record, hr, hm⟩ := lazyRun_jointSigningProgram_memory_trace key.parameter inputs hencoding words publicReplies selections rows
+        state.1.memory.routing key.root message (by simpa only [publicDigestLoop_eq] using hin) state.1 hvalid.1 hvalid.2 raw hraw
+      have heq : raw = (some record, raw.2) := Prod.ext hr rfl
+      rw [heq]
+      refine ⟨annotation.1, proposalOfSigningRecord message record raw.2.memory.external.cache
+        (record.1.2.elim annotation.2 Prod.fst), rfl, rfl, rfl, ?_, ?_⟩
+      · change raw.2.memory.log ++ [⟨message, record.1.1⟩] = state.1.memory.log ++ [⟨message, record.1.1⟩]
+        rw [hm]; rfl
+      · change raw.2.memory.external.hashCalls = state.1.memory.external.hashCalls + record.2.hashCalls
+        rw [hm]; rfl
+
+theorem monitoredStep_active_accounting (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState inputs)
+    (hvalid : MonitoredValid inputs state) (hinputs : requestInputs key input ⊆ inputs)
+    (hbefore : MonitoredAccounting state) (hbank : MonitoredBankComplete key required state)
+    (hactive : CertificateMonitorActive key budget input (monitorView state))
+    (result : Option ((OracleWorld + SigningSpec).Range input) × MonitoredState inputs)
+    (hresult : monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state result ≠ 0)
+    (hlive : result.1 ≠ none) :
+    result.2.2.spent = result.2.1.memory.external.hashCalls ∧ result.2.2.log = result.2.1.memory.log := by
+  obtain ⟨length, record, _, hmonitor, _, hlog, hhash⟩ :=
+    monitoredStep_record key inputs hencoding words publicReplies selections rows budget required stopAfter input state hvalid hinputs result hresult hlive
+  rw [hmonitor, certificateMonitorUpdate, if_pos hactive]
+  constructor
+  · change state.2.spent + record.trace.hashCalls = result.2.1.memory.external.hashCalls
+    rw [hbefore hactive.1, hhash]
+  · change (proposalRecordLogState input state.2.log record).2 = result.2.1.memory.log
+    rw [(hbank hactive.1).1, hlog]
+
+theorem monitoredStep_ready_after (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState inputs)
+    (hvalid : MonitoredValid inputs state) (hinputs : requestInputs key input ⊆ inputs)
+    (hbefore : MonitoredAccounting state) (hbank : MonitoredBankComplete key required state)
+    (hsize : CacheSizeBound state.1.memory)
+    (hsigned : SigningDigestsCached key.parameter state.1.memory.external.cache key.root state.1.memory.log)
+    (hactive : CertificateMonitorActive key budget input (monitorView state))
+    (result : Option ((OracleWorld + SigningSpec).Range input) × MonitoredState inputs)
+    (hresult : monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state result ≠ 0)
+    (hlive : result.1 ≠ none) (hcost : result.2.1.memory.external.hashCalls ≤ budget) (hbudget : budget ≤ 2 ^ 127)
+    (hclean : ¬ CertificateCacheExceptional key result.2.1.memory.external.cache) :
+    CertificateMonitorReady key budget (monitorView result.2) := by
+  obtain ⟨hspent, hlog⟩ := monitoredStep_active_accounting key inputs hencoding words publicReplies selections rows budget required stopAfter
+    input state hvalid hinputs hbefore hbank hactive result hresult hlive
+  have hsize' := monitoredStep_cacheSizeBound key inputs hencoding words publicReplies selections rows budget required stopAfter
+    input state hvalid hinputs hsize result hresult
+  have hsigned' := monitoredStep_digestsCached key inputs hencoding words publicReplies selections rows budget required stopAfter
+    input state hvalid hinputs hsigned result hresult
+  change SigningDigestsCached key.parameter result.2.1.memory.external.cache key.root result.2.2.log ∧
+    ProposalCacheBound key result.2.1.memory.external.cache result.2.2.spent ∧ result.2.2.spent ≤ budget
+  rw [hspent, hlog]
+  exact ⟨hsigned', proposalCacheBound_of_no_cache_exception key _ (Finite.of_enncard_le hsize') _
+    (hcost.trans hbudget) hsize' hclean, hcost⟩
+
+private theorem update_stopped_eq (key : SecretKey) (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState) (length : Nat) (record : ProposalExecutionRecord input)
+    (hactive : CertificateMonitorActive key budget input state)
+    (hready : CertificateMonitorReady key budget
+      (record.cache, certificateMonitorUpdate key budget required stopAfter input state length record)) :
+    (certificateMonitorUpdate key budget required stopAfter input state length record).stopped = stopAfter input state length record := by
+  unfold certificateMonitorUpdate at hready ⊢
+  rw [if_pos hactive] at hready ⊢
+  simp only [CertificateMonitorReady] at hready ⊢
+  simp only [hready, and_self, not_true_eq_false, decide_false, Bool.or_false]
+
+omit stopAfter in
+theorem monitoredStep_stopped_iff_prefix (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState inputs)
+    (hvalid : MonitoredValid inputs state) (hinputs : requestInputs key input ⊆ inputs)
+    (hbefore : MonitoredAccounting state) (hbank : MonitoredBankComplete key required state)
+    (hsize : CacheSizeBound state.1.memory)
+    (hsigned : SigningDigestsCached key.parameter state.1.memory.external.cache key.root state.1.memory.log)
+    (hactive : CertificateMonitorActive key budget input (monitorView state))
+    (result : Option ((OracleWorld + SigningSpec).Range input) × MonitoredState inputs)
+    (hresult : monitoredStep key inputs hencoding words publicReplies selections rows budget required (proposalStop (fun _ _ _ _ => false))
+      input state result ≠ 0)
+    (hlive : result.1 ≠ none) (hcost : result.2.1.memory.external.hashCalls ≤ budget) (hbudget : budget ≤ 2 ^ 127)
+    (hclean : ¬ CertificateCacheExceptional key result.2.1.memory.external.cache) :
+    result.2.2.stopped = true ↔ ProposalPrefixExceptional result.2.2.proposals result.2.2.log.length := by
+  let stop : CertificateStopRule := proposalStop (fun _ _ _ _ => false)
+  have hready := monitoredStep_ready_after key inputs hencoding words publicReplies selections rows budget required stop input state
+    hvalid hinputs hbefore hbank hsize hsigned hactive result hresult hlive hcost hbudget hclean
+  obtain ⟨length, record, _, hmonitor, hcache, _, _⟩ :=
+    monitoredStep_record key inputs hencoding words publicReplies selections rows budget required stop input state hvalid hinputs result hresult hlive
+  have hready' : CertificateMonitorReady key budget
+      (record.cache, certificateMonitorUpdate key budget required stop input (monitorView state) length record) := by
+    rw [hcache, ← hmonitor]
+    exact hready
+  have hstop := update_stopped_eq key budget required stop input (monitorView state) length record hactive hready'
+  have hprefix := proposalPrefixStop_eq_after_exception key budget required stop input (monitorView state) length record hactive
+  rw [← hmonitor] at hstop hprefix
+  simp only [hstop, stop, proposalStop, Bool.or_false, hprefix, decide_eq_true_eq]
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMonitoredCoverage.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMonitoredCoverage.lean
new file mode 100644
index 000000000..3e2af0bee
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMonitoredCoverage.lean
@@ -0,0 +1,99 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualMonitoredErasure
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec ENNReal CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs sourceInputs
+set_option backward.isDefEq.respectTransparency false
+
+variable (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+  (words : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+  (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+noncomputable def expectedMonitoredCharge {Result : Type}
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) : MonitoredState inputs → ENNReal :=
+  OracleComp.construct (fun _ _ => 0) (fun input _ next state =>
+    certificateMonitorCharge key budget required input (monitorView state) +
+      ∑' result, Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+        result.1.elim 0 (fun answer => next answer result.2)) computation
+
+theorem expectedMonitoredCharge_pure {Result : Type} (value : Result) (state : MonitoredState inputs) :
+    expectedMonitoredCharge key inputs hencoding words publicReplies selections rows budget required stopAfter (pure value) state = 0 := rfl
+
+theorem expectedMonitoredCharge_query_bind {Result : Type} (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Result)
+    (state : MonitoredState inputs) :
+    expectedMonitoredCharge key inputs hencoding words publicReplies selections rows budget required stopAfter
+      (liftM ((OracleWorld + SigningSpec).query input) >>= next) state =
+      certificateMonitorCharge key budget required input (monitorView state) +
+        ∑' result, Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+          result.1.elim 0 (fun answer =>
+            expectedMonitoredCharge key inputs hencoding words publicReplies selections rows budget required stopAfter (next answer) result.2) := rfl
+
+theorem expected_monitoredRun_potential_le {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : MonitoredState inputs) (hvalid : MonitoredValid inputs state)
+    (hinputs : sourceInputs key computation ⊆ inputs) :
+    (∑' result, Pr[= result | monitoredRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state] *
+      certificateMonitorPotential key budget required (monitorView result.2)) ≤
+      certificateMonitorPotential key budget required (monitorView state) +
+        expectedMonitoredCharge key inputs hencoding words publicReplies selections rows budget required stopAfter computation state := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value =>
+      simp only [monitoredRun_pure, tsum_probOutput_pure_mul, expectedMonitoredCharge_pure, add_zero, le_refl]
+  | query_bind input next ih =>
+      rw [monitoredRun_query_bind, tsum_probOutput_bind_mul, expectedMonitoredCharge_query_bind]
+      calc
+        _ ≤ ∑' result, Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+            (certificateMonitorPotential key budget required (monitorView result.2) + result.1.elim 0 (fun answer =>
+              expectedMonitoredCharge key inputs hencoding words publicReplies selections rows budget required stopAfter (next answer) result.2)) := by
+          apply ENNReal.tsum_le_tsum
+          intro result
+          by_cases hr : Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] = 0
+          · simp only [hr, zero_mul, le_refl]
+          · rw [SPMF.probOutput_eq_apply] at hr
+            have hafter := monitoredStep_valid key inputs hencoding words publicReplies selections rows budget required stopAfter input state hvalid result hr
+            apply mul_le_mul' le_rfl
+            rcases result with ⟨answer, after⟩
+            cases answer with
+            | none => simp only [Option.elim_none, tsum_probOutput_pure_mul, add_zero, le_refl]
+            | some answer =>
+                exact ih answer after hafter ((sourceInputs_next_subset key input next answer).trans hinputs)
+        _ = (∑' result, Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+            certificateMonitorPotential key budget required (monitorView result.2)) +
+            ∑' result, Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+              result.1.elim 0 (fun answer =>
+                expectedMonitoredCharge key inputs hencoding words publicReplies selections rows budget required stopAfter (next answer) result.2) := by
+          simp only [mul_add, ENNReal.tsum_add]
+        _ ≤ _ := by
+          rw [← add_assoc]
+          exact add_le_add (expected_monitoredStep_potential_le key inputs hencoding words publicReplies selections rows budget required stopAfter
+            input state ((requestInputs_subset key input next).trans hinputs) hvalid.1 hvalid.2) le_rfl
+
+theorem expected_monitoredRun_count_le {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : MonitoredState inputs) (hvalid : MonitoredValid inputs state)
+    (hinputs : sourceInputs key computation ⊆ inputs) :
+    (∑' result, Pr[= result | monitoredRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state] *
+      certificateBankCount result.2.2.bank) ≤
+      certificateMonitorPotential key budget required (monitorView state) +
+        expectedMonitoredCharge key inputs hencoding words publicReplies selections rows budget required stopAfter computation state := by
+  apply le_trans ?_ (expected_monitoredRun_potential_le key inputs hencoding words publicReplies selections rows budget required stopAfter
+    computation state hvalid hinputs)
+  exact ENNReal.tsum_le_tsum fun result => mul_le_mul' le_rfl (certificateBankCount_le_bankedCacheWeight _ _ _ _ _)
+
+theorem expected_monitoredRun_count_le_charge {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : State inputs) (spent : Nat) (stopped : Bool)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hinputs : sourceInputs key computation ⊆ inputs)
+    (hnone : ∀ input, FtsProbeSimulation.MessageHashInput key.parameter input → state.memory.external.cache input = none) :
+    (∑' result, Pr[= result | monitoredRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation
+        (state, initialCertificateMonitor spent stopped)] * certificateBankCount result.2.2.bank) ≤
+      expectedMonitoredCharge key inputs hencoding words publicReplies selections rows budget required stopAfter computation
+        (state, initialCertificateMonitor spent stopped) := by
+  have h := expected_monitoredRun_count_le key inputs hencoding words publicReplies selections rows budget required stopAfter computation
+    (state, initialCertificateMonitor spent stopped) ⟨ha, hcovered⟩ hinputs
+  simpa only [monitorView, certificateMonitorPotential_initial key budget spent required state.memory.external.cache stopped hnone, zero_add] using h
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMonitoredErasure.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMonitoredErasure.lean
new file mode 100644
index 000000000..a49e4222e
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMonitoredErasure.lean
@@ -0,0 +1,149 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualMonitoredStep
+
+/-! ## RetainedResidualMessageHistory -/
+
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+set_option backward.isDefEq.respectTransparency false
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+  (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem lazyRun_rowsCovered {Result : Type} (computation : OracleComp (World inputs) Result) (state : State inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) (result : Option Result × State inputs)
+    (hresult : lazyRun (environment parameter inputs hencoding words publicReplies selections rows) computation state result ≠ 0) :
+    ResidualByteFrontend.RowsCovered inputs (project result.2) := by
+  rw [← run_erasure _ _ state ha, RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨actual, _, hresult⟩ := hresult
+  rw [RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨seed, _, hresult⟩ := hresult
+  exact observedRun_rowsCovered parameter inputs hencoding words publicReplies selections rows actual seed computation state hcovered result hresult
+
+end SphincsSecurity.Concrete.RetainedResidual
+
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs sourceInputs
+set_option backward.isDefEq.respectTransparency false
+
+variable (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+  (words : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem lazyRun_record_bind {Result : Type} (message : Message) (record : SigningRecord)
+    (next : Unit → OracleComp (World inputs) Result) (state : State inputs) :
+    lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+      (recordSigning inputs message record >>= next) state =
+      lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+        (next ()) { state with memory := state.memory.recordSigning message record } := by
+  rw [recordSigning, lazyRun, runWith_query_bind]
+  simp only [lazyImpl, environment, OptionT.run_mk, StateT.run_mk, SPMF.lift_pure, pure_bind, Option.elim_some, lazyRun]
+
+theorem lazyRun_signingProgram (message : Message) (state : State inputs) :
+    lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+      (signingProgram inputs key.parameter key.root words selections message) state =
+      (fun result : Option SigningRecord × State inputs => result.1.elim (none, result.2) fun record =>
+        (some record.1.1, { result.2 with memory := result.2.memory.recordSigning message record })) <$>
+        lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+          (simulateQ (embed inputs state.memory.routing)
+            (ResidualByteFrontend.jointSigningProgram inputs key.parameter key.root state.memory.routing.known words selections message)) state := by
+  rw [signingProgram, lazyRun_routing_bind, lazyRun_bind, map_eq_bind_pure_comp]
+  apply RetainedObservation.bind_congr
+  rintro ⟨answer, after⟩ _
+  cases answer with
+  | none => rfl
+  | some record =>
+      rw [Option.elim_some, lazyRun_record_bind]
+      exact runWith_pure _ _ _
+
+variable (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+theorem monitoredStep_erasure (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState inputs) :
+    (fun result => (result.1, result.2.1)) <$>
+      monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state =
+      lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+        (adversaryImpl inputs key.parameter key.root words selections input) state.1 := by
+  cases input with
+  | inl input =>
+      rw [monitoredStep, Functor.map_map]
+      change id <$> _ = _
+      rw [id_map]
+      rfl
+  | inr message =>
+      rw [monitoredStep, map_bind]
+      calc
+        _ = (liftM (signingAnnotation key budget message (monitorView state)) : SPMF _) >>= fun _ =>
+            lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+              (signingProgram inputs key.parameter key.root words selections message) state.1 := by
+          apply RetainedObservation.bind_congr
+          intro annotation _
+          rw [Functor.map_map, lazyRun_signingProgram]
+          congr 1
+          funext result
+          rcases result with ⟨answer, after⟩
+          cases answer <;> rfl
+        _ = _ := RetainedObservation.lift_bind_const _ _
+
+def MonitoredValid (state : MonitoredState inputs) : Prop :=
+  (∀ coordinate, (state.1.candidates coordinate).Nonempty) ∧ ResidualByteFrontend.RowsCovered inputs (project state.1)
+
+theorem monitoredStep_valid (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState inputs)
+    (hvalid : MonitoredValid inputs state) (result : Option ((OracleWorld + SigningSpec).Range input) × MonitoredState inputs)
+    (hresult : monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state result ≠ 0) :
+    MonitoredValid inputs result.2 := by
+  have h := map_nonzero _ (fun result => (result.1, result.2.1)) result hresult
+  rw [monitoredStep_erasure] at h
+  exact ⟨lazyRun_nonempty _ _ state.1 hvalid.1 _ h,
+    lazyRun_rowsCovered key.parameter inputs hencoding words publicReplies selections rows _ state.1 hvalid.1 hvalid.2 _ h⟩
+
+noncomputable def monitoredRun {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : MonitoredState inputs) : SPMF (Option Result × MonitoredState inputs) :=
+  (simulateQ (monitoredImpl key inputs hencoding words publicReplies selections rows budget required stopAfter) computation).run.run state
+
+theorem monitoredRun_pure {Result : Type} (value : Result) (state : MonitoredState inputs) :
+    monitoredRun key inputs hencoding words publicReplies selections rows budget required stopAfter (pure value) state =
+      pure (some value, state) := by
+  simp only [monitoredRun, simulateQ_pure, OptionT.run_pure, StateT.run_pure]
+
+theorem monitoredRun_query_bind {Result : Type} (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Result)
+    (state : MonitoredState inputs) :
+    monitoredRun key inputs hencoding words publicReplies selections rows budget required stopAfter
+      (liftM ((OracleWorld + SigningSpec).query input) >>= next) state =
+      (monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state >>= fun result =>
+        result.1.elim (pure (none, result.2)) fun answer =>
+          monitoredRun key inputs hencoding words publicReplies selections rows budget required stopAfter (next answer) result.2) := by
+  simp only [monitoredRun, simulateQ_bind, simulateQ_spec_query, OptionT.run_bind, Option.elimM, StateT.run_bind,
+    monitoredImpl, OptionT.run_mk, StateT.run_mk]
+  apply congrArg (_ >>= ·)
+  funext result
+  rcases result with ⟨answer, after⟩
+  cases answer <;> rfl
+
+theorem monitoredRun_erasure {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : MonitoredState inputs) :
+    (fun result => (result.1, result.2.1)) <$>
+      monitoredRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state =
+      lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+        (simulateQ (adversaryImpl inputs key.parameter key.root words selections) computation) state.1 := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [monitoredRun_pure, map_pure, simulateQ_pure, lazyRun, runWith_pure]
+  | query_bind input next ih =>
+      rw [monitoredRun_query_bind, map_bind, simulateQ_bind, simulateQ_spec_query, lazyRun_bind,
+        ← monitoredStep_erasure key inputs hencoding words publicReplies selections rows budget required stopAfter input state,
+        bind_map_left]
+      apply RetainedObservation.bind_congr
+      rintro ⟨answer, after⟩ _
+      cases answer with
+      | none => simp only [Option.elim_none, map_pure]
+      | some answer => exact ih answer after
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMonitoredGame.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMonitoredGame.lean
new file mode 100644
index 000000000..50f87d9cd
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMonitoredGame.lean
@@ -0,0 +1,122 @@
+import SphincsSecurity.Proof.Residual.RetainedResidualCertificateTransfer
+import SphincsSecurity.Proof.Residual.RetainedResidualGameTransfer
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs sourceInputs
+  signDigestLoop signAfterDigest gameInputs
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def initialMonitoredPrior (parameter : PublicParameter) (adversary : Adversary)
+    (encoding : ReferenceEncodingAuxiliary) (dummy : OtsReferenceWords)
+    (exposed : InitialPublicLabels (referenceFamilyWords encoding.selections dummy)) (high : CanonicalGraphHighHalves)
+    (budget : Nat) (stopAfter : CertificateStopRule) : SPMF (Option (Forgery × Bool) × MonitoredState (gameInputs adversary)) := do
+  let words := referenceFamilyWords encoding.selections dummy
+  let labels ← UniformTableCompletion.complete (initialAllowed words exposed)
+  let key : SecretKey := ⟨parameter, knownRoot (initialKnown words exposed), coordinateOtsSecrets labels, coordinateFtsSecrets labels⟩
+  initialMonitoredSource key adversary encoding dummy exposed high budget Finset.univ (proposalStop stopAfter) false
+
+theorem initialMonitoredPrior_erasure (parameter : PublicParameter) (adversary : Adversary)
+    (encoding : ReferenceEncodingAuxiliary) (dummy : OtsReferenceWords)
+    (exposed : InitialPublicLabels (referenceFamilyWords encoding.selections dummy)) (high : CanonicalGraphHighHalves)
+    (budget : Nat) (stopAfter : CertificateStopRule) :
+    (fun result => (result.1, result.2.1)) <$> initialMonitoredPrior parameter adversary encoding dummy exposed high budget stopAfter =
+      lazyRun
+        (environment parameter (gameInputs adversary) (canonicalEncodingInputs_subset_retainedGameInputs adversary parameter)
+          (referenceFamilyWords encoding.selections dummy)
+          (coordinateGraphLabels (initialKnown (referenceFamilyWords encoding.selections dummy) exposed) high)
+          encoding.selections encoding.rows)
+        (simulateQ (adversaryImpl (gameInputs adversary) parameter
+          (knownRoot (initialKnown (referenceFamilyWords encoding.selections dummy) exposed))
+          (referenceFamilyWords encoding.selections dummy) encoding.selections)
+          (FtsProbeSimulation.unloggedRetainedRestComputation adversary
+            ⟨knownRoot (initialKnown (referenceFamilyWords encoding.selections dummy) exposed), parameter⟩))
+        (initialState (gameInputs adversary) (referenceFamilyWords encoding.selections dummy) exposed) := by
+  simp only [initialMonitoredPrior, map_bind, initialMonitoredSource, monitoredRun_erasure]
+  rw [UniformTableCompletion.complete_of_nonempty _ (initialAllowed_nonempty _ exposed)]
+  exact RetainedObservation.lift_bind_const _
+    (lazyRun
+      (environment parameter (gameInputs adversary) (canonicalEncodingInputs_subset_retainedGameInputs adversary parameter)
+        (referenceFamilyWords encoding.selections dummy)
+        (coordinateGraphLabels (initialKnown (referenceFamilyWords encoding.selections dummy) exposed) high)
+        encoding.selections encoding.rows)
+      (simulateQ (adversaryImpl (gameInputs adversary) parameter
+        (knownRoot (initialKnown (referenceFamilyWords encoding.selections dummy) exposed))
+        (referenceFamilyWords encoding.selections dummy) encoding.selections)
+        (FtsProbeSimulation.unloggedRetainedRestComputation adversary
+          ⟨knownRoot (initialKnown (referenceFamilyWords encoding.selections dummy) exposed), parameter⟩))
+      (initialState (gameInputs adversary) (referenceFamilyWords encoding.selections dummy) exposed))
+
+noncomputable def monitoredSourceGame (dummy : OtsReferenceWords) (adversary : Adversary)
+    (budget : Nat) (stopAfter : CertificateStopRule) : SPMF (Option (Forgery × Bool) × MonitoredState (gameInputs adversary)) := do
+  let parameter ← 𝒟[sampleParameter]
+  let encoding ← 𝒟[referenceEncodingAuxiliarySample]
+  let words := referenceFamilyWords encoding.selections dummy
+  let high ← 𝒟[PMF.uniformOfFintype CanonicalGraphHighHalves]
+  let exposed ← 𝒟[PMF.uniformOfFintype (InitialPublicLabels words)]
+  initialMonitoredPrior parameter adversary encoding dummy exposed high budget stopAfter
+
+theorem monitoredSourceGame_erasure (dummy : OtsReferenceWords) (adversary : Adversary)
+    (budget : Nat) (stopAfter : CertificateStopRule) :
+    (fun result => (result.1, result.2.1)) <$> monitoredSourceGame dummy adversary budget stopAfter = sourceGame dummy adversary := by
+  simp only [monitoredSourceGame, map_bind, initialMonitoredPrior_erasure, sourceGame]
+
+private theorem probEvent_bind_add_le_const_add {A B : Type} (law : SPMF A) (next : A → SPMF B)
+    (left right exception : B → Prop) (bound : ENNReal)
+    (h : ∀ value, law value ≠ 0 → Pr[left | next value] + Pr[right | next value] ≤ bound + Pr[exception | next value]) :
+    Pr[left | law >>= next] + Pr[right | law >>= next] ≤ bound + Pr[exception | law >>= next] := by
+  simp only [probEvent_bind_eq_tsum, ← ENNReal.tsum_add, ← mul_add]
+  calc
+    _ ≤ ∑' value, Pr[= value | law] * (bound + Pr[exception | next value]) := by
+      apply ENNReal.tsum_le_tsum
+      intro value
+      by_cases hvalue : law value = 0
+      · simp only [SPMF.probOutput_eq_apply, hvalue, zero_mul, le_refl]
+      exact mul_le_mul' le_rfl (h value hvalue)
+    _ = (∑' value, Pr[= value | law]) * bound + ∑' value, Pr[= value | law] * Pr[exception | next value] := by
+      simp only [mul_add, ENNReal.tsum_add, ENNReal.tsum_mul_right]
+    _ ≤ _ := add_le_add (mul_le_of_le_one_left' tsum_probOutput_le_one) le_rfl
+
+theorem monitoredSourceGame_stop_add_strong_le (dummy : OtsReferenceWords)
+    (hdummy : ∀ lay tree leaf, TargetSum.Valid (dummy lay tree leaf)) (adversary : Adversary)
+    (budget : Nat) (stopAfter : CertificateStopRule)
+    (hcost : HasHashQueryBound scheme adversary budget) (hbudget : budget ≤ 2 ^ 127) :
+    Pr[fun result => result.1 = none | monitoredSourceGame dummy adversary budget stopAfter] +
+      Pr[MonitoredStrongWin | monitoredSourceGame dummy adversary budget stopAfter] ≤
+      ENNReal.ofReal (2 * ((budget : ℝ) / 2 ^ digestBits) - ((budget : ℝ) / 2 ^ digestBits) ^ 2) +
+        (budget : ENNReal) * (11 / 2 ^ 144 : ENNReal) +
+        Pr[MonitoredStrongException | monitoredSourceGame dummy adversary budget stopAfter] := by
+  unfold monitoredSourceGame
+  apply probEvent_bind_add_le_const_add
+  intro parameter hparameter
+  have hparameter' : parameter ∈ support sampleParameter := (mem_support_iff_evalDist_apply_ne_zero _ _).mpr hparameter
+  apply probEvent_bind_add_le_const_add
+  intro encoding hencoding
+  have hencoding' : encoding ∈ referenceEncodingAuxiliarySample.support := by
+    apply (PMF.mem_support_iff _ _).mpr
+    simpa only [PMF.evalDist_eq, SPMF.liftM_apply] using hencoding
+  apply probEvent_bind_add_le_const_add
+  intro high _
+  apply probEvent_bind_add_le_const_add
+  intro exposed _
+  unfold initialMonitoredPrior
+  apply probEvent_bind_add_le_const_add
+  intro labels _
+  exact initialMonitoredSource_stop_add_strong_le _ adversary encoding dummy hdummy exposed high budget stopAfter false
+    hparameter' hencoding' rfl hcost hbudget
+
+theorem forgeAdvantage_le_monitored_bound_add_exception (dummy : OtsReferenceWords)
+    (hdummy : ∀ lay tree leaf, TargetSum.Valid (dummy lay tree leaf)) (adversary : Adversary)
+    (budget : Nat) (stopAfter : CertificateStopRule)
+    (hcost : HasHashQueryBound scheme adversary budget) (hbudget : budget ≤ 2 ^ 127) :
+    forgeAdvantage scheme adversary ≤
+      ENNReal.ofReal (2 * ((budget : ℝ) / 2 ^ digestBits) - ((budget : ℝ) / 2 ^ digestBits) ^ 2) +
+        (budget : ENNReal) * (11 / 2 ^ 144 : ENNReal) +
+        Pr[MonitoredStrongException | monitoredSourceGame dummy adversary budget stopAfter] := by
+  have h := forgeAdvantage_le_source_stop_add_win dummy adversary
+  rw [← monitoredSourceGame_erasure dummy adversary budget stopAfter, probEvent_map, probEvent_map] at h
+  exact h.trans (monitoredSourceGame_stop_add_strong_le dummy hdummy adversary budget stopAfter hcost hbudget)
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMonitoredPayment.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMonitoredPayment.lean
new file mode 100644
index 000000000..378332148
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMonitoredPayment.lean
@@ -0,0 +1,213 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualMonitoredCoverage
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec ENNReal CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open FtsProbeSimulation (MessageHashInput)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs sourceInputs
+set_option backward.isDefEq.respectTransparency false
+
+variable (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+  (words : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+  (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+theorem monitoredStep_bind_const {Other : Type} (input : (OracleWorld + SigningSpec).Domain)
+    (state : MonitoredState inputs) (ha : ∀ coordinate, (state.1.candidates coordinate).Nonempty) (after : SPMF Other) :
+    (monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state >>= fun _ => after) = after := by
+  have h := lazyRun_bind_const (environment key.parameter inputs hencoding words publicReplies selections rows)
+    (adversaryImpl inputs key.parameter key.root words selections input) state.1 ha after
+  rw [← monitoredStep_erasure key inputs hencoding words publicReplies selections rows budget required stopAfter input state,
+    bind_map_left] at h
+  exact h
+
+theorem tsum_monitoredStep_eq_one (input : (OracleWorld + SigningSpec).Domain)
+    (state : MonitoredState inputs) (ha : ∀ coordinate, (state.1.candidates coordinate).Nonempty) :
+    (∑' result, Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state]) = 1 := by
+  have h := congrArg (fun law : SPMF Unit => Pr[= () | law])
+    (monitoredStep_bind_const key inputs hencoding words publicReplies selections rows budget required stopAfter input state ha (pure ()))
+  simpa only [probOutput_bind_eq_tsum, probOutput_pure_self, mul_one] using h
+
+attribute [local irreducible] lazyRun environment ResidualByteFrontend.jointSigningProgram
+  certificateMonitorCharge certificateMonitorMass certificateMonitorUpdate monitorView monitoredSigningResult
+
+theorem stopped_world_message_charges_zero (input : OracleWorld.Domain) (state : MonitoredState inputs)
+    (hinputs : requestInputs key (.inl input) ⊆ inputs)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state.1))
+    (result : Option (OracleWorld.Range input) × State inputs)
+    (hresult : lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+      (externalProgram inputs key.parameter words selections (liftM (OracleWorld.query input))) state.1 result ≠ 0)
+    (hnone : result.1 = none) :
+    freshWorldTargetHashCost key.parameter state.1.memory.external.cache input = 0 ∧
+      hashQueryCharge (FtsProbeSimulation.messageHashCharge key.parameter) state.1.memory.external.cache input = 0 := by
+  cases input with
+  | inl input => exact ⟨rfl, rfl⟩
+  | inr input =>
+      by_cases hm : MessageHashInput key.parameter input
+      · rw [lazyRun_externalProgram] at hresult
+        have h := map_nonzero _ cacheResult result hresult
+        rw [lazyByteRun_world_message_rom key.parameter inputs hencoding words publicReplies selections rows
+          state.1.memory.routing (.inr input) hinputs (fun hash heq => by cases heq; exact hm) state.1 hcovered,
+          map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at h
+        obtain ⟨answer, _, h⟩ := h
+        simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at h
+        have hs := congrArg Prod.fst h
+        simp only [cacheResult, hnone, Prod.map_fst] at hs
+        contradiction
+      · simp only [freshWorldTargetHashCost, hm, false_and, if_false, hashQueryCharge, Sum.elim_inr,
+          FtsProbeSimulation.messageHashCharge, and_self]
+
+theorem monitoredStep_creation_counters (input : (OracleWorld + SigningSpec).Domain)
+    (state : MonitoredState inputs) (hvalid : MonitoredValid inputs state)
+    (hinputs : requestInputs key input ⊆ inputs)
+    (result : Option ((OracleWorld + SigningSpec).Range input) × MonitoredState inputs)
+    (hresult : monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state result ≠ 0) :
+    result.2.2.creationCost = state.2.creationCost + certificateMonitorCharge key budget required input (monitorView state) ∧
+    result.2.2.creationMass = state.2.creationMass + certificateMonitorMass key budget input (monitorView state) := by
+  cases input with
+  | inl input =>
+      rw [monitoredStep, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨raw, hraw, hresult⟩ := hresult
+      simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      by_cases hn : raw.1 = none
+      · have hz := (stopped_world_message_charges_zero key inputs hencoding words publicReplies selections rows input state hinputs hvalid.2 raw hraw hn).1
+        have hc : certificateMonitorCharge key budget required (.inl input) (monitorView state) = 0 := by
+          unfold certificateMonitorCharge targetCreationMultiplier monitorView
+          simp only [hz, Nat.cast_zero, zero_mul, ite_self]
+        have hm : certificateMonitorMass key budget (.inl input) (monitorView state) = 0 := by
+          unfold certificateMonitorMass targetCreationMultiplier monitorView
+          simp only [hz, Nat.cast_zero, ite_self]
+        simp only [monitoredWorldResult, hn, Option.elim_none, hc, hm, add_zero, and_self]
+      · obtain ⟨answer, ha⟩ := Option.ne_none_iff_exists'.mp hn
+        simp only [monitoredWorldResult, ha, Option.elim_some]
+        rw [certificateMonitorUpdate_creationCost, certificateMonitorUpdate_creationMass]
+        simp only [monitorView, and_self]
+  | inr message =>
+      rw [monitoredStep, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨annotation, _, hresult⟩ := hresult
+      rw [map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨raw, hraw, hresult⟩ := hresult
+      simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      have hin := digestInputs_of_request key inputs words selections message state.1.memory.routing.known hinputs
+      obtain ⟨record, hr⟩ := lazyRun_jointSigningProgram_some key.parameter inputs hencoding words publicReplies selections rows
+        state.1.memory.routing key.root message (by simpa only [publicDigestLoop_eq] using hin) state.1 hvalid.1 hvalid.2 raw hraw
+      have heq : raw = (some record, raw.2) := Prod.ext hr rfl
+      rw [heq]
+      simp only [monitoredSigningResult]
+      rw [certificateMonitorUpdate_creationCost, certificateMonitorUpdate_creationMass]
+      simp only [monitorView, and_self]
+
+theorem expected_monitoredStep_creationCost (input : (OracleWorld + SigningSpec).Domain)
+    (state : MonitoredState inputs) (hvalid : MonitoredValid inputs state)
+    (hinputs : requestInputs key input ⊆ inputs) :
+    (∑' result, Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+      result.2.2.creationCost) = state.2.creationCost + certificateMonitorCharge key budget required input (monitorView state) := by
+  calc
+    _ = ∑' result, Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+        (state.2.creationCost + certificateMonitorCharge key budget required input (monitorView state)) := by
+      apply tsum_congr
+      intro result
+      by_cases hr : Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] = 0
+      · simp only [hr, zero_mul]
+      · rw [SPMF.probOutput_eq_apply] at hr
+        rw [(monitoredStep_creation_counters key inputs hencoding words publicReplies selections rows budget required stopAfter
+          input state hvalid hinputs result hr).1]
+    _ = _ := by
+      rw [ENNReal.tsum_mul_right, tsum_monitoredStep_eq_one key inputs hencoding words publicReplies selections rows
+        budget required stopAfter input state hvalid.1, one_mul]
+
+noncomputable def expectedMonitoredPayment
+    (charge : (OracleWorld + SigningSpec).Domain → CertificateMonitorState → ENNReal)
+    {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result) : MonitoredState inputs → ENNReal :=
+  OracleComp.construct (fun _ _ => 0) (fun input _ next state =>
+    charge input (monitorView state) +
+      ∑' result, Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+        result.1.elim 0 (fun answer => next answer result.2)) computation
+
+theorem expected_monitoredRun_accumulator (counter : CertificateMonitor → ENNReal)
+    (charge : (OracleWorld + SigningSpec).Domain → CertificateMonitorState → ENNReal)
+    (hstep : ∀ input state, MonitoredValid inputs state → requestInputs key input ⊆ inputs →
+      (∑' result, Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+        counter result.2.2) = counter state.2 + charge input (monitorView state))
+    {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : MonitoredState inputs) (hvalid : MonitoredValid inputs state)
+    (hinputs : sourceInputs key computation ⊆ inputs) :
+    (∑' result, Pr[= result | monitoredRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state] *
+      counter result.2.2) = counter state.2 +
+        expectedMonitoredPayment key inputs hencoding words publicReplies selections rows budget required stopAfter charge computation state := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [monitoredRun_pure, tsum_probOutput_pure_mul, expectedMonitoredPayment, construct_pure, add_zero]
+  | query_bind input next ih =>
+      rw [monitoredRun_query_bind, tsum_probOutput_bind_mul]
+      change _ = counter state.2 + (charge input (monitorView state) +
+        ∑' result, Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+          result.1.elim 0 (fun answer =>
+            expectedMonitoredPayment key inputs hencoding words publicReplies selections rows budget required stopAfter charge (next answer) result.2))
+      calc
+        _ = ∑' result, Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+            (counter result.2.2 + result.1.elim 0 (fun answer =>
+              expectedMonitoredPayment key inputs hencoding words publicReplies selections rows budget required stopAfter charge (next answer) result.2)) := by
+          apply tsum_congr
+          intro result
+          by_cases hr : Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] = 0
+          · simp only [hr, zero_mul]
+          · rw [SPMF.probOutput_eq_apply] at hr
+            have hafter := monitoredStep_valid key inputs hencoding words publicReplies selections rows budget required stopAfter
+              input state hvalid result hr
+            apply congrArg (_ * ·)
+            rcases result with ⟨answer, after⟩
+            cases answer with
+            | none => simp only [Option.elim_none, tsum_probOutput_pure_mul, add_zero]
+            | some answer => exact ih answer after hafter ((sourceInputs_next_subset key input next answer).trans hinputs)
+        _ = _ := by
+          simp only [mul_add, ENNReal.tsum_add]
+          rw [hstep input state hvalid ((requestInputs_subset key input next).trans hinputs), add_assoc]
+
+theorem expectedMonitoredPayment_mono
+    (first second : (OracleWorld + SigningSpec).Domain → CertificateMonitorState → ENNReal)
+    (hle : ∀ input state, first input state ≤ second input state)
+    {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result) (state : MonitoredState inputs) :
+    expectedMonitoredPayment key inputs hencoding words publicReplies selections rows budget required stopAfter first computation state ≤
+      expectedMonitoredPayment key inputs hencoding words publicReplies selections rows budget required stopAfter second computation state := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => exact le_rfl
+  | query_bind input next ih =>
+      apply add_le_add (hle input (monitorView state))
+      apply ENNReal.tsum_le_tsum
+      rintro ⟨answer, after⟩
+      apply mul_le_mul' le_rfl
+      cases answer with
+      | none => exact le_rfl
+      | some answer => exact ih answer after
+
+theorem expected_monitoredRun_creationCost {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : MonitoredState inputs) (hvalid : MonitoredValid inputs state)
+    (hinputs : sourceInputs key computation ⊆ inputs) :
+    (∑' result, Pr[= result | monitoredRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state] *
+      result.2.2.creationCost) = state.2.creationCost +
+        expectedMonitoredCharge key inputs hencoding words publicReplies selections rows budget required stopAfter computation state :=
+  expected_monitoredRun_accumulator key inputs hencoding words publicReplies selections rows budget required stopAfter
+    CertificateMonitor.creationCost (certificateMonitorCharge key budget required)
+    (expected_monitoredStep_creationCost key inputs hencoding words publicReplies selections rows budget required stopAfter)
+    computation state hvalid hinputs
+
+theorem expected_monitoredRun_count_le_creationCost {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : State inputs) (spent : Nat) (stopped : Bool)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hinputs : sourceInputs key computation ⊆ inputs)
+    (hnone : ∀ input, MessageHashInput key.parameter input → state.memory.external.cache input = none) :
+    (∑' result, Pr[= result | monitoredRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation
+        (state, initialCertificateMonitor spent stopped)] * certificateBankCount result.2.2.bank) ≤
+      ∑' result, Pr[= result | monitoredRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation
+        (state, initialCertificateMonitor spent stopped)] * result.2.2.creationCost := by
+  rw [expected_monitoredRun_creationCost key inputs hencoding words publicReplies selections rows budget required stopAfter computation
+    (state, initialCertificateMonitor spent stopped) ⟨ha, hcovered⟩ hinputs]
+  simp only [initialCertificateMonitor, zero_add]
+  exact expected_monitoredRun_count_le_charge key inputs hencoding words publicReplies selections rows budget required stopAfter
+    computation state spent stopped ha hcovered hinputs hnone
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMonitoredStep.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMonitoredStep.lean
new file mode 100644
index 000000000..0373611b1
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualMonitoredStep.lean
@@ -0,0 +1,157 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualCoverageStep
+import SphincsSecurity.Proof.Residual.RetainedResidualSource
+import SphincsSecurity.Proof.Residual.RetainedResidualWorldCoverage
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec ENNReal CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs sourceInputs
+set_option backward.isDefEq.respectTransparency false
+
+abbrev MonitoredState (inputs : Finset HashInput) := State inputs × CertificateMonitor
+
+def monitorView {inputs : Finset HashInput} (state : MonitoredState inputs) : CertificateMonitorState :=
+  (state.1.memory.external.cache, state.2)
+
+noncomputable def signingAnnotation (key : SecretKey) (budget : Nat) (message : Message)
+    (monitor : CertificateMonitorState) : PMF (Nat × Index) :=
+  let lengths := if CertificateMonitorActive key budget (.inr message) monitor then
+    proposalBlockLength targetProposalAcceptance targetProposalAcceptance_ne_zero targetProposalAcceptance_lt_one.le
+  else PMF.pure 0
+  lengths.bind fun length => (PMF.uniformOfFintype Index).map (length, ·)
+
+noncomputable def monitoredWorldResult {inputs : Finset HashInput} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule) (input : OracleWorld.Domain)
+    (before : MonitoredState inputs) (result : Option (OracleWorld.Range input) × State inputs) :
+    Option (OracleWorld.Range input) × MonitoredState inputs :=
+  (result.1, result.2, result.1.elim { before.2 with stopped := true } fun answer =>
+    certificateMonitorUpdate key budget required stopAfter (.inl input) (monitorView before) 0
+      (proposalOfWorldResult key.parameter input (answer, result.2.memory.external.cache)))
+
+noncomputable def monitoredSigningResult {inputs : Finset HashInput} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule) (message : Message)
+    (annotation : Nat × Index) (before : MonitoredState inputs) (result : Option SigningRecord × State inputs) :
+    Option (Option Signature) × MonitoredState inputs :=
+  match result.1 with
+  | none => (none, result.2, { before.2 with stopped := true })
+  | some record =>
+      (some record.1.1, { result.2 with memory := result.2.memory.recordSigning message record },
+        certificateMonitorUpdate key budget required stopAfter (.inr message) (monitorView before) annotation.1
+          (proposalOfSigningRecord message record result.2.memory.external.cache (record.1.2.elim annotation.2 Prod.fst)))
+
+theorem monitoredWorldResult_potential {inputs : Finset HashInput} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule) (input : OracleWorld.Domain)
+    (before : MonitoredState inputs) (result : Option (OracleWorld.Range input) × State inputs) :
+    certificateMonitorPotential key budget required
+      (monitorView (monitoredWorldResult key budget required stopAfter input before result).2) =
+      worldMonitorValue key budget required stopAfter input (monitorView before) 0 (cacheResult result) := by
+  rcases result with ⟨answer, after⟩
+  cases answer with
+  | none => simp only [monitoredWorldResult, monitorView, worldMonitorValue, cacheResult, Option.elim_none,
+      certificateMonitorPotential, bankedTargetEnvelope_stopped]
+  | some answer => rfl
+
+theorem monitoredSigningResult_some_potential {inputs : Finset HashInput} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule) (message : Message) (annotation : Nat × Index)
+    (before : MonitoredState inputs) (record : SigningRecord) (after : State inputs) :
+    certificateMonitorPotential key budget required
+      (monitorView (monitoredSigningResult key budget required stopAfter message annotation before (some record, after)).2) =
+      certificateMonitorPotential key budget required
+        (originalProposalAdvance (certificateMonitorUpdate key budget required stopAfter) (.inr message) (monitorView before) annotation.1
+          (proposalOfSigningRecord message record after.memory.external.cache (record.1.2.elim annotation.2 Prod.fst))) := rfl
+
+variable (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+  (words : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+  (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+noncomputable def monitoredStep :
+    (input : (OracleWorld + SigningSpec).Domain) → MonitoredState inputs →
+      SPMF (Option ((OracleWorld + SigningSpec).Range input) × MonitoredState inputs)
+  | .inl input, state =>
+      monitoredWorldResult key budget required stopAfter input state <$>
+        lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+          (externalProgram inputs key.parameter words selections (liftM (OracleWorld.query input))) state.1
+  | .inr message, state =>
+      (liftM (signingAnnotation key budget message (monitorView state)) : SPMF _) >>= fun annotation =>
+        monitoredSigningResult key budget required stopAfter message annotation state <$>
+          lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+            (simulateQ (embed inputs state.1.memory.routing)
+              (ResidualByteFrontend.jointSigningProgram inputs key.parameter key.root state.1.memory.routing.known words selections message)) state.1
+
+noncomputable def monitoredImpl : QueryImpl (OracleWorld + SigningSpec) (OptionT (StateT (MonitoredState inputs) SPMF)) :=
+  fun input => OptionT.mk (StateT.mk (monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input))
+
+attribute [local irreducible] lazyRun environment ResidualByteFrontend.jointSigningProgram
+  certificateMonitorPotential certificateMonitorCharge bankedTargetEnvelope signDigestLoop
+  certificateMonitorUpdate originalProposalAdvance proposalOfSigningRecord monitorView monitoredSigningResult
+
+include words selections in
+theorem digestInputs_of_request (message : Message) (known : Labels)
+    (hinputs : requestInputs key (.inr message) ⊆ inputs) :
+    hashInputs (signDigestLoop digestAttemptLimit key message) ⊆ inputs := by
+  have h := (ResidualByteFrontend.hashInputs_publicSigningWork_subset_signWithView key known words selections message).trans hinputs
+  simpa only [ResidualByteFrontend.hashInputs_publicSigningWork, publicDigestLoop_eq] using h
+
+theorem expected_monitoredSigningResult_potential_le (message : Message) (annotation : Nat × Index)
+    (state : MonitoredState inputs) (hinputs : requestInputs key (.inr message) ⊆ inputs)
+    (ha : ∀ coordinate, (state.1.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state.1)) :
+    (∑' result, Pr[= result | lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+        (simulateQ (embed inputs state.1.memory.routing)
+          (ResidualByteFrontend.jointSigningProgram inputs key.parameter key.root state.1.memory.routing.known words selections message)) state.1] *
+      certificateMonitorPotential key budget required
+        (monitorView (monitoredSigningResult key budget required stopAfter message annotation state result).2)) ≤
+      certificateMonitorPotential key budget required (monitorView state) +
+        certificateMonitorCharge key budget required (.inr message) (monitorView state) := by
+  have hin := digestInputs_of_request key inputs words selections message state.1.memory.routing.known hinputs
+  apply le_trans ?_ (expected_lazySigning_certificateMonitor_le key.parameter inputs hencoding words publicReplies selections rows
+    state.1.memory.routing key rfl budget required stopAfter message (monitorView state) (fun _ => annotation.1)
+    (fun result => result.1.elim annotation.2 (fun record => record.1.2.elim annotation.2 Prod.fst)) hin state.1
+    (by unfold monitorView; rfl) ha hcovered)
+  apply ENNReal.tsum_le_tsum
+  intro result
+  by_cases hr : Pr[= result | lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+      (simulateQ (embed inputs state.1.memory.routing)
+        (ResidualByteFrontend.jointSigningProgram inputs key.parameter key.root state.1.memory.routing.known words selections message)) state.1] = 0
+  · simp only [hr, zero_mul, le_refl]
+  · rw [SPMF.probOutput_eq_apply] at hr
+    obtain ⟨record, hrecord⟩ := lazyRun_jointSigningProgram_some key.parameter inputs hencoding words publicReplies selections rows
+      state.1.memory.routing key.root message (by simpa only [publicDigestLoop_eq] using hin) state.1 ha hcovered result hr
+    apply mul_le_mul' le_rfl
+    have heq : result = (some record, result.2) := Prod.ext hrecord rfl
+    rw [heq, monitoredSigningResult_some_potential]
+    conv_rhs => dsimp only [Option.elim]
+    exact le_refl _
+
+theorem expected_monitoredStep_potential_le (input : (OracleWorld + SigningSpec).Domain)
+    (state : MonitoredState inputs) (hinputs : requestInputs key input ⊆ inputs)
+    (ha : ∀ coordinate, (state.1.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state.1)) :
+    (∑' result, Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+      certificateMonitorPotential key budget required (monitorView result.2)) ≤
+      certificateMonitorPotential key budget required (monitorView state) + certificateMonitorCharge key budget required input (monitorView state) := by
+  cases input with
+  | inl input =>
+      rw [monitoredStep, tsum_probOutput_map_mul]
+      simp only [monitoredWorldResult_potential]
+      exact expected_externalProgram_certificateMonitor_le key.parameter inputs hencoding words publicReplies selections rows
+        key rfl budget required stopAfter input hinputs (monitorView state) (fun _ => 0) state.1 (by unfold monitorView; rfl) ha hcovered
+  | inr message =>
+      rw [monitoredStep, tsum_probOutput_bind_mul]
+      simp only [tsum_probOutput_map_mul]
+      calc
+        _ ≤ ∑' annotation, Pr[= annotation | (liftM (signingAnnotation key budget message (monitorView state)) : SPMF _)] *
+            (certificateMonitorPotential key budget required (monitorView state) +
+              certificateMonitorCharge key budget required (.inr message) (monitorView state)) := by
+          apply ENNReal.tsum_le_tsum
+          intro annotation
+          exact mul_le_mul' le_rfl (expected_monitoredSigningResult_potential_le key inputs hencoding words publicReplies selections rows
+            budget required stopAfter message annotation state hinputs ha hcovered)
+        _ ≤ _ := by
+          rw [ENNReal.tsum_mul_right]
+          exact mul_le_of_le_one_left' tsum_probOutput_le_one
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualNativePayment.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualNativePayment.lean
new file mode 100644
index 000000000..1f7cd2f55
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualNativePayment.lean
@@ -0,0 +1,116 @@
+import SphincsSecurity.Proof.Residual.RetainedResidualCacheKernels
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec ENNReal CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs sourceInputs
+  signDigestLoop lazyRun environment ResidualByteFrontend.jointSigningProgram
+set_option backward.isDefEq.respectTransparency false
+
+private theorem expected_add_le {Result : Type} (law : SPMF Result) (base charge : ENNReal)
+    (increment total : Result → ENNReal) (hmass : (∑' result, Pr[= result | law]) = 1)
+    (hcharge : (∑' result, Pr[= result | law] * increment result) = charge)
+    (hpoint : ∀ result, law result ≠ 0 → base + increment result ≤ total result) :
+    base + charge ≤ ∑' result, Pr[= result | law] * total result := by
+  calc
+    _ = ∑' result, Pr[= result | law] * (base + increment result) := by
+      simp only [mul_add, ENNReal.tsum_add, ENNReal.tsum_mul_right, hmass, hcharge, one_mul]
+    _ ≤ _ := by
+      apply ENNReal.tsum_le_tsum
+      intro result
+      by_cases hr : law result = 0
+      · simp only [SPMF.probOutput_eq_apply, hr, zero_mul, le_refl]
+      · exact mul_le_mul' le_rfl (hpoint result hr)
+
+variable (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+  (words : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem lazySigning_messageCalls_hashCalls (message : Message) (state : State inputs)
+    (hinputs : requestInputs key (.inr message) ⊆ inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (result : Option SigningRecord × State inputs)
+    (hr : lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+      (simulateQ (embed inputs state.memory.routing)
+        (ResidualByteFrontend.jointSigningProgram inputs key.parameter key.root state.memory.routing.known words selections message)) state result ≠ 0) :
+    (state.memory.external.hashCalls : ENNReal) + result.1.elim 0 (fun record => (record.2.messageCalls.length : ENNReal)) ≤
+      (result.2.memory.external.hashCalls : ENNReal) := by
+  have hin := digestInputs_of_request key inputs words selections message state.memory.routing.known hinputs
+  obtain ⟨record, hrecord, hmemory⟩ := lazyRun_jointSigningProgram_memory_trace key.parameter inputs hencoding words publicReplies selections rows
+    state.memory.routing key.root message (by simpa only [publicDigestLoop_eq] using hin) state ha hcovered result hr
+  rw [hrecord, Option.elim_some, hmemory]
+  change (state.memory.external.hashCalls : ENNReal) + record.2.messageCalls.length ≤
+    ((state.memory.external.hashCalls + record.2.hashCalls : Nat) : ENNReal)
+  rw [Nat.cast_add]
+  exact add_le_add le_rfl (Nat.cast_le.mpr (List.length_filterMap_le _ _))
+
+private theorem tsum_lazyRun_eq_one {Result : Type} (computation : OracleComp (World inputs) Result)
+    (state : State inputs) (ha : ∀ coordinate, (state.candidates coordinate).Nonempty) :
+    (∑' result, Pr[= result | lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows) computation state]) = 1 := by
+  have h := congrArg (fun law : SPMF Unit => Pr[= () | law])
+    (lazyRun_bind_const (environment key.parameter inputs hencoding words publicReplies selections rows) computation state ha (pure ()))
+  simpa only [probOutput_bind_eq_tsum, probOutput_pure_self, mul_one] using h
+
+theorem expected_lazySigning_hashCalls_lower (message : Message) (state : State inputs)
+    (hinputs : requestInputs key (.inr message) ⊆ inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) :
+    (state.memory.external.hashCalls : ENNReal) + digestAttemptExpectation digestAttemptLimit key message state.memory.external.cache ≤
+      ∑' result, Pr[= result | lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+        (simulateQ (embed inputs state.memory.routing)
+          (ResidualByteFrontend.jointSigningProgram inputs key.parameter key.root state.memory.routing.known words selections message)) state] *
+        (result.2.memory.external.hashCalls : ENNReal) := by
+  exact expected_add_le _ _ _ (fun result => result.1.elim 0 (fun record => (record.2.messageCalls.length : ENNReal))) _
+    (tsum_lazyRun_eq_one key inputs hencoding words publicReplies selections rows _ state ha)
+    (expected_lazySigning_messageCalls key inputs hencoding words publicReplies selections rows message state hinputs ha hcovered)
+    (lazySigning_messageCalls_hashCalls key inputs hencoding words publicReplies selections rows message state hinputs ha hcovered)
+
+theorem expected_lazyWorld_hashCalls_lower (world : OracleWorld.Domain) (state : State inputs)
+    (hinputs : hashInputs (liftM (OracleWorld.query world)) ⊆ inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty) :
+    (state.memory.external.hashCalls : ENNReal) + hashQueryCharge (FtsProbeSimulation.messageHashCharge key.parameter) state.memory.external.cache world ≤
+      ∑' result, Pr[= result | lazyByteRun key.parameter inputs hencoding words publicReplies selections rows state.memory.routing
+        (liftM (OracleWorld.query world)) state] * (result.2.memory.external.hashCalls : ENNReal) := by
+  have hm : (∑' result, Pr[= result | lazyByteRun key.parameter inputs hencoding words publicReplies selections rows state.memory.routing
+      (liftM (OracleWorld.query world)) state]) = 1 :=
+    tsum_lazyRun_eq_one key inputs hencoding words publicReplies selections rows _ state ha
+  refine expected_add_le _ _ _ (fun _ => hashQueryCharge (FtsProbeSimulation.messageHashCharge key.parameter) state.memory.external.cache world) _ hm ?_ ?_
+  · rw [ENNReal.tsum_mul_right, hm, one_mul]
+  · intro result hr
+    rw [lazyByteRun_world_hashCalls key.parameter inputs hencoding words publicReplies selections rows state.memory.routing world hinputs state ha result hr, Nat.cast_add]
+    apply add_le_add le_rfl
+    cases world <;> simp [hashQueryCharge, FtsProbeSimulation.messageHashCharge]
+    split <;> norm_num
+
+variable (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+private theorem expected_signing_annotation_hashCalls (message : Message) (state : MonitoredState inputs)
+    (native : SPMF (Option SigningRecord × State inputs)) :
+    (∑' result, Pr[= result | ((liftM (signingAnnotation key budget message (monitorView state)) : SPMF _) >>= fun annotation =>
+      monitoredSigningResult key budget required stopAfter message annotation state <$> native)] *
+        (result.2.1.memory.external.hashCalls : ENNReal)) =
+      ∑' result, Pr[= result | native] * (result.2.memory.external.hashCalls : ENNReal) := by
+  have hprojection (annotation : Nat × Index) (raw : Option SigningRecord × State inputs) :
+      (monitoredSigningResult key budget required stopAfter message annotation state raw).2.1.memory.external.hashCalls = raw.2.memory.external.hashCalls := by
+    rcases raw with ⟨answer, after⟩
+    cases answer <;> rfl
+  rw [tsum_probOutput_bind_mul]
+  simp only [tsum_probOutput_map_mul, hprojection, ENNReal.tsum_mul_right]
+  simp only [SPMF.probOutput_eq_apply, SPMF.liftM_apply, PMF.tsum_coe, one_mul]
+
+theorem expected_monitoredStep_hashCalls_lower (input : (OracleWorld + SigningSpec).Domain)
+    (state : MonitoredState inputs) (hvalid : MonitoredValid inputs state) (hinputs : requestInputs key input ⊆ inputs) :
+    (state.1.memory.external.hashCalls : ENNReal) + nativeMessageCharge key input (monitorView state) ≤
+      ∑' result, Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+        (result.2.1.memory.external.hashCalls : ENNReal) := by
+  cases input with
+  | inl world =>
+      rw [monitoredStep, tsum_probOutput_map_mul, lazyRun_externalProgram]
+      exact expected_lazyWorld_hashCalls_lower key inputs hencoding words publicReplies selections rows world state.1 hinputs hvalid.1
+  | inr message =>
+      exact (expected_lazySigning_hashCalls_lower key inputs hencoding words publicReplies selections rows message state.1 hinputs hvalid.1 hvalid.2).trans_eq
+        (expected_signing_annotation_hashCalls key inputs budget required stopAfter message state _).symm
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualOriginalBudget.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualOriginalBudget.lean
new file mode 100644
index 000000000..e5b37778c
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualOriginalBudget.lean
@@ -0,0 +1,267 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FtsProbeVerifierSource
+import SphincsSecurity.Proof.Residual.RetainedResidualEnvelope
+import SphincsSecurity.Proof.Residual.RetainedResidualInitial
+import SphincsSecurity.Proof.Residual.RetainedResidualMessagePayment
+import SphincsSecurity.Proof.Residual.RetainedResidualResources
+import SphincsSecurity.Proof.Residual.RetainedWorldCoverBudget
+
+/-! ## PublicSigningInitial -/
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting UniformTableCompletion
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+theorem initialKnown_root (words : OtsReferenceWords) (exposedValues : InitialPublicLabels words)
+    (labels : Labels) (hlabels : complete (initialAllowed words exposedValues) labels ≠ 0)
+    (high : CanonicalGraphHighHalves) :
+    knownRoot (initialKnown words exposedValues) = canonicalGraphRoot (coordinateGraphLabels labels high) := by
+  apply knownRoot_eq (coordinateOtsSecrets labels) (coordinateFtsSecrets labels)
+    (coordinateGraphLabels labels high) words (fun _ _ _ => False)
+  rw [coordinateGraphLabels_value]
+  exact initialKnown_agrees words exposedValues labels hlabels
+
+end SphincsSecurity.Concrete
+
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec ENNReal CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open FtsProbeSimulation (unloggedRetainedRestComputation liftOracleWorldLeft)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs sourceInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+  gameInputs initialAllowed initialKnown referenceFamilyWords
+  simulateQ adversaryImpl unloggedRetainedRestComputation environment lazyRun
+set_option backward.isDefEq.respectTransparency false
+
+theorem sourceInputs_bind_subset {A B : Type} (key : SecretKey) (inputs : Finset HashInput)
+    (first : OracleComp (OracleWorld + SigningSpec) A) (next : A → OracleComp (OracleWorld + SigningSpec) B)
+    (hfirst : sourceInputs key first ⊆ inputs) (hnext : ∀ value, sourceInputs key (next value) ⊆ inputs) :
+    sourceInputs key (first >>= next) ⊆ inputs := by
+  induction first using OracleComp.inductionOn with
+  | pure value => simpa only [pure_bind] using hnext value
+  | query_bind input tail ih =>
+      rw [bind_assoc, sourceInputs_query_bind]
+      apply Finset.union_subset
+      · exact (requestInputs_subset key input tail).trans hfirst
+      · intro row hrow
+        obtain ⟨answer, _, hrow⟩ := Finset.mem_biUnion.mp hrow
+        exact ih answer ((sourceInputs_next_subset key input tail answer).trans hfirst) hrow
+
+theorem sourceInputs_world (key : SecretKey) {Result : Type} (computation : OracleComp OracleWorld Result) :
+    sourceInputs key (liftOracleWorldLeft computation) = hashInputs computation := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => simp only [liftOracleWorldLeft, liftM_pure, sourceInputs_pure, hashInputs_pure]
+  | query_bind input next ih =>
+      rw [FtsProbeSimulation.liftOracleWorldLeft_query_bind, sourceInputs_query_bind, hashInputs_query_bind]
+      simp only [ih, requestInputs]
+      rw [← bind_pure (liftM (OracleWorld.query input)), hashInputs_query_bind]
+      have hempty : (Finset.univ.biUnion fun _ : OracleWorld.Range input => (∅ : Finset HashInput)) = ∅ := by
+        ext row
+        simp
+      simp only [hashInputs_pure, hempty, Finset.union_empty]
+      cases input <;> rfl
+
+theorem sourceInputs_unlogged_subset_gameInputs (adversary : Adversary) (key : SecretKey) :
+    sourceInputs key (unloggedRetainedRestComputation adversary ⟨key.root, key.parameter⟩) ⊆ gameInputs adversary := by
+  rw [unloggedRetainedRestComputation]
+  apply sourceInputs_bind_subset key (gameInputs adversary) _ _ (sourceInputs_subset_gameInputs adversary key)
+  intro forgery
+  apply sourceInputs_bind_subset
+  · rw [sourceInputs_world]
+    exact verifyInputs_subset_gameInputs adversary key forgery
+  · intro checked
+    rw [sourceInputs_pure]
+    exact Finset.empty_subset _
+
+theorem referenceEncodingAuxiliary_support_seed (inputs : Finset HashInput) (encoding : ReferenceEncodingAuxiliary)
+    (hencoding : encoding ∈ referenceEncodingAuxiliarySample.support) (seed : inputs → HashOutput) :
+    (⟨encoding.selections, encoding.rows, seed⟩ : ReferenceAuxiliary inputs) ∈ (referenceAuxiliarySample inputs).support := by
+  rw [referenceEncodingAuxiliarySample, PMF.mem_support_bind_iff] at hencoding
+  obtain ⟨selections, hs, hencoding⟩ := hencoding
+  rw [PMF.mem_support_map_iff] at hencoding
+  obtain ⟨rows, hr, rfl⟩ := hencoding
+  rw [referenceAuxiliarySample, PMF.mem_support_bind_iff]
+  refine ⟨selections, hs, ?_⟩
+  rw [PMF.mem_support_bind_iff]
+  refine ⟨rows, hr, ?_⟩
+  rw [PMF.mem_support_map_iff]
+  exact ⟨seed, by simp, rfl⟩
+
+theorem observedInitialSource_hashCalls_le (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter)
+    (inputs : Finset HashInput) (hcanonical : canonicalEncodingInputs parameter ⊆ inputs)
+    (encoding : ReferenceEncodingAuxiliary) (hencoding : encoding ∈ referenceEncodingAuxiliarySample.support)
+    (seed : inputs → HashOutput)
+    (dummy : OtsReferenceWords) (exposed : InitialPublicLabels (referenceFamilyWords encoding.selections dummy))
+    (high : CanonicalGraphHighHalves) (labels : Labels)
+    (hlabels : UniformTableCompletion.complete (initialAllowed (referenceFamilyWords encoding.selections dummy) exposed) labels ≠ 0)
+    (adversary : Adversary)
+    (hinputs : ∀ key : SecretKey, sourceInputs key (unloggedRetainedRestComputation adversary ⟨key.root, key.parameter⟩) ⊆ inputs)
+    (q : Nat) (hq : HasHashQueryBound scheme adversary q) (result : Option (Forgery × Bool) × State inputs)
+    (hresult : observedRun
+      (environment parameter inputs hcanonical (referenceFamilyWords encoding.selections dummy)
+        (coordinateGraphLabels (initialKnown (referenceFamilyWords encoding.selections dummy) exposed) high) encoding.selections encoding.rows)
+      labels seed
+      (simulateQ (adversaryImpl inputs parameter (knownRoot (initialKnown (referenceFamilyWords encoding.selections dummy) exposed))
+        (referenceFamilyWords encoding.selections dummy) encoding.selections)
+        (unloggedRetainedRestComputation adversary ⟨knownRoot (initialKnown (referenceFamilyWords encoding.selections dummy) exposed), parameter⟩))
+      (initialState inputs (referenceFamilyWords encoding.selections dummy) exposed) result ≠ 0) :
+    result.2.memory.external.hashCalls ≤ q := by
+  let auxiliary : ReferenceAuxiliary inputs := ⟨encoding.selections, encoding.rows, seed⟩
+  have hauxiliary := referenceEncodingAuxiliary_support_seed inputs encoding hencoding seed
+  let context := initialContext parameter inputs hcanonical auxiliary hauxiliary dummy exposed high labels
+  have hroot : context.key.root = canonicalGraphRoot context.graph :=
+    initialKnown_root (referenceFamilyWords encoding.selections dummy) exposed labels hlabels high
+  obtain ⟨hcost, hbound⟩ := context.rest_queryBound hroot hparameter adversary q hq
+  have hsource := FtsProbeSimulation.expanded_unloggedRetainedRest_queryBound adversary context.key (q - 1212415) hbound
+  have hcompatible : Compatible context (initialState inputs (referenceFamilyWords encoding.selections dummy) exposed).memory := by
+    refine ⟨?_, ?_, ?_, ?_, ?_⟩
+    · simpa only [context, auxiliary, Context.words, Context.actual, initialContext, coordinateGraphLabels_value, initialState, initialMemory] using
+        initialKnown_agrees (referenceFamilyWords encoding.selections dummy) exposed labels hlabels
+    · exact initialKnown_graphReplies (referenceFamilyWords encoding.selections dummy) exposed labels hlabels high
+    · intro input answer hanswer; cases hanswer
+    · intro input answer hanswer; cases hanswer
+    · intro input answer hanswer; cases hanswer
+  have hrun : observedRun context.environment context.actual context.auxiliary.seed
+      (simulateQ (adversaryImpl inputs context.key.parameter context.key.root context.words context.auxiliary.selections)
+        (unloggedRetainedRestComputation adversary ⟨context.key.root, context.key.parameter⟩))
+      (initialState inputs (referenceFamilyWords encoding.selections dummy) exposed) result ≠ 0 := by
+    simpa only [context, auxiliary, Context.environment, Context.actual, Context.words, initialContext, coordinateGraphLabels_value] using hresult
+  have h := observedRun_source_hashCalls_le context (unloggedRetainedRestComputation adversary ⟨context.key.root, context.key.parameter⟩)
+    (hinputs context.key) (q - 1212415) hsource
+    (initialState inputs (referenceFamilyWords encoding.selections dummy) exposed) (initialState_rowsCovered _ _ exposed)
+    hcompatible result hrun
+  simp only [initialState, initialMemory] at h
+  omega
+
+private theorem lazyRun_observed_support {Result : Type} (inputs : Finset HashInput)
+    (runEnvironment : AdaptiveResidualLabels.Environment (ControlSpec inputs) CanonicalCoordinate inputs Memory)
+    (computation : OracleComp (World inputs) Result) (state : State inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty) (result : Option Result × State inputs)
+    (hresult : lazyRun runEnvironment computation state result ≠ 0) :
+    ∃ labels seed, UniformTableCompletion.complete state.candidates labels ≠ 0 ∧
+      observedRun runEnvironment labels seed computation state result ≠ 0 := by
+  rw [← run_erasure _ _ state ha, RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨labels, hlabels, hresult⟩ := hresult
+  rw [RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨seed, _, hresult⟩ := hresult
+  exact ⟨labels, seed, hlabels, hresult⟩
+
+theorem initialState_completion (inputs : Finset HashInput) (words : OtsReferenceWords)
+    (exposed : InitialPublicLabels words) :
+    UniformTableCompletion.complete (initialState inputs words exposed).candidates =
+      UniformTableCompletion.complete (initialAllowed words exposed) := rfl
+
+theorem lazyInitialSource_hashCalls_le (parameter : PublicParameter) (hparameter : parameter ∈ support sampleParameter)
+    (inputs : Finset HashInput) (hcanonical : canonicalEncodingInputs parameter ⊆ inputs) (adversary : Adversary)
+    (hinputs : ∀ key : SecretKey, sourceInputs key (unloggedRetainedRestComputation adversary ⟨key.root, key.parameter⟩) ⊆ inputs)
+    (encoding : ReferenceEncodingAuxiliary)
+    (hencoding : encoding ∈ referenceEncodingAuxiliarySample.support) (dummy : OtsReferenceWords)
+    (exposed : InitialPublicLabels (referenceFamilyWords encoding.selections dummy)) (high : CanonicalGraphHighHalves)
+    (q : Nat) (hq : HasHashQueryBound scheme adversary q)
+    (result : Option (Forgery × Bool) × State inputs)
+    (hresult : lazyRun
+      (environment parameter inputs hcanonical
+        (referenceFamilyWords encoding.selections dummy) (coordinateGraphLabels (initialKnown (referenceFamilyWords encoding.selections dummy) exposed) high)
+        encoding.selections encoding.rows)
+      (simulateQ (adversaryImpl inputs parameter (knownRoot (initialKnown (referenceFamilyWords encoding.selections dummy) exposed))
+        (referenceFamilyWords encoding.selections dummy) encoding.selections)
+        (unloggedRetainedRestComputation adversary ⟨knownRoot (initialKnown (referenceFamilyWords encoding.selections dummy) exposed), parameter⟩))
+      (initialState inputs (referenceFamilyWords encoding.selections dummy) exposed) result ≠ 0) :
+    result.2.memory.external.hashCalls ≤ q := by
+  obtain ⟨labels, seed, hlabels, hresult⟩ := lazyRun_observed_support inputs _ _ _
+    (initialAllowed_nonempty _ exposed) result hresult
+  rw [initialState_completion] at hlabels
+  exact observedInitialSource_hashCalls_le parameter hparameter inputs
+    hcanonical encoding hencoding seed dummy exposed high labels hlabels adversary hinputs q hq result hresult
+
+variable (key : SecretKey) (adversary : Adversary) (encoding : ReferenceEncodingAuxiliary) (dummy : OtsReferenceWords)
+  (exposed : InitialPublicLabels (referenceFamilyWords encoding.selections dummy)) (high : CanonicalGraphHighHalves)
+  (q : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule) (stopped : Bool)
+
+noncomputable def initialMonitoredSource : SPMF (Option (Forgery × Bool) × MonitoredState (gameInputs adversary)) :=
+  monitoredRun key (gameInputs adversary) (canonicalEncodingInputs_subset_retainedGameInputs adversary key.parameter)
+    (referenceFamilyWords encoding.selections dummy)
+    (coordinateGraphLabels (initialKnown (referenceFamilyWords encoding.selections dummy) exposed) high)
+    encoding.selections encoding.rows q required stopAfter
+    (unloggedRetainedRestComputation adversary ⟨key.root, key.parameter⟩)
+    (initialState (gameInputs adversary) (referenceFamilyWords encoding.selections dummy) exposed,
+      initialCertificateMonitor 1212415 stopped)
+
+theorem initialMonitoredSource_hashCalls_le (hparameter : key.parameter ∈ support sampleParameter)
+    (hencoding : encoding ∈ referenceEncodingAuxiliarySample.support)
+    (hroot : key.root = knownRoot (initialKnown (referenceFamilyWords encoding.selections dummy) exposed))
+    (hq : HasHashQueryBound scheme adversary q)
+    (result : Option (Forgery × Bool) × MonitoredState (gameInputs adversary))
+    (hresult : initialMonitoredSource key adversary encoding dummy exposed high q required stopAfter stopped result ≠ 0) :
+    result.2.1.memory.external.hashCalls ≤ q := by
+  unfold initialMonitoredSource at hresult
+  have hnative := map_nonzero _ (fun result => (result.1, result.2.1)) result hresult
+  rw [monitoredRun_erasure, hroot] at hnative
+  exact lazyInitialSource_hashCalls_le key.parameter hparameter (gameInputs adversary)
+    (canonicalEncodingInputs_subset_retainedGameInputs adversary key.parameter) adversary
+    (sourceInputs_unlogged_subset_gameInputs adversary) encoding hencoding dummy exposed high q hq (result.1, result.2.1) hnative
+
+theorem initialMonitoredSource_resources
+    (result : Option (Forgery × Bool) × MonitoredState (gameInputs adversary))
+    (hresult : initialMonitoredSource key adversary encoding dummy exposed high q required stopAfter stopped result ≠ 0) :
+    MonitorResources result.2.2 result.2.1.memory :=
+  monitoredRun_resources key (gameInputs adversary) (canonicalEncodingInputs_subset_retainedGameInputs adversary key.parameter)
+    (referenceFamilyWords encoding.selections dummy)
+    (coordinateGraphLabels (initialKnown (referenceFamilyWords encoding.selections dummy) exposed) high)
+    encoding.selections encoding.rows q required stopAfter
+    (unloggedRetainedRestComputation adversary ⟨key.root, key.parameter⟩)
+    (initialState (gameInputs adversary) (referenceFamilyWords encoding.selections dummy) exposed,
+      initialCertificateMonitor 1212415 stopped)
+    ⟨initialAllowed_nonempty _ exposed, initialState_rowsCovered _ _ exposed⟩
+    (sourceInputs_unlogged_subset_gameInputs adversary key) ⟨le_rfl, bot_le, Nat.zero_le _⟩ result hresult
+
+theorem initialMonitoredSource_creationMass_le (hparameter : key.parameter ∈ support sampleParameter)
+    (hencoding : encoding ∈ referenceEncodingAuxiliarySample.support)
+    (hroot : key.root = knownRoot (initialKnown (referenceFamilyWords encoding.selections dummy) exposed))
+    (hq : HasHashQueryBound scheme adversary q)
+    (result : Option (Forgery × Bool) × MonitoredState (gameInputs adversary))
+    (hresult : initialMonitoredSource key adversary encoding dummy exposed high q required stopAfter stopped result ≠ 0) :
+    result.2.2.creationMass ≤ (q : ENNReal) :=
+  (initialMonitoredSource_resources key adversary encoding dummy exposed high q required stopAfter stopped result hresult).2.1.trans
+    (Nat.cast_le.mpr (initialMonitoredSource_hashCalls_le key adversary encoding dummy exposed high q required stopAfter stopped
+      hparameter hencoding hroot hq result hresult))
+
+theorem expected_initialMonitoredSource_count_le_creationCost :
+    (∑' result, Pr[= result | initialMonitoredSource key adversary encoding dummy exposed high q required stopAfter stopped] *
+      certificateBankCount result.2.2.bank) ≤
+    ∑' result, Pr[= result | initialMonitoredSource key adversary encoding dummy exposed high q required stopAfter stopped] *
+      result.2.2.creationCost :=
+  expected_monitoredRun_count_le_creationCost key (gameInputs adversary)
+    (canonicalEncodingInputs_subset_retainedGameInputs adversary key.parameter) (referenceFamilyWords encoding.selections dummy)
+    (coordinateGraphLabels (initialKnown (referenceFamilyWords encoding.selections dummy) exposed) high)
+    encoding.selections encoding.rows q required stopAfter (unloggedRetainedRestComputation adversary ⟨key.root, key.parameter⟩)
+    (initialState (gameInputs adversary) (referenceFamilyWords encoding.selections dummy) exposed) 1212415 stopped
+    (initialAllowed_nonempty _ exposed) (initialState_rowsCovered _ _ exposed)
+    (sourceInputs_unlogged_subset_gameInputs adversary key) (fun _ _ => rfl)
+
+theorem expected_initialMonitoredSource_creationMass_le_messageCalls :
+    (∑' result, Pr[= result | initialMonitoredSource key adversary encoding dummy exposed high q required stopAfter stopped] *
+      result.2.2.creationMass) ≤
+    ∑' result, Pr[= result | initialMonitoredSource key adversary encoding dummy exposed high q required stopAfter stopped] *
+      result.2.1.memory.messageCalls.length := by
+  have hpayment := expected_monitoredRun_creationMass_le_messageCalls key (gameInputs adversary)
+    (canonicalEncodingInputs_subset_retainedGameInputs adversary key.parameter) (referenceFamilyWords encoding.selections dummy)
+    (coordinateGraphLabels (initialKnown (referenceFamilyWords encoding.selections dummy) exposed) high)
+    encoding.selections encoding.rows q required stopAfter (unloggedRetainedRestComputation adversary ⟨key.root, key.parameter⟩)
+    (initialState (gameInputs adversary) (referenceFamilyWords encoding.selections dummy) exposed) 1212415 stopped
+    (initialAllowed_nonempty _ exposed) (initialState_rowsCovered _ _ exposed)
+    (sourceInputs_unlogged_subset_gameInputs adversary key)
+  apply hpayment.trans
+  apply ENNReal.tsum_le_tsum
+  intro result
+  by_cases hr : Pr[= result | initialMonitoredSource key adversary encoding dummy exposed high q required stopAfter stopped] = 0
+  · change Pr[= result | initialMonitoredSource key adversary encoding dummy exposed high q required stopAfter stopped] * _ ≤ _
+    simp only [hr, zero_mul, le_refl]
+  · rw [SPMF.probOutput_eq_apply] at hr
+    exact mul_le_mul' le_rfl (Nat.cast_le.mpr
+      (initialMonitoredSource_resources key adversary encoding dummy exposed high q required stopAfter stopped result hr).2.2)
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualPaymentBudget.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualPaymentBudget.lean
new file mode 100644
index 000000000..05025f043
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualPaymentBudget.lean
@@ -0,0 +1,93 @@
+import SphincsSecurity.Proof.Residual.RetainedResidualNativePayment
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec ENNReal CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs sourceInputs
+set_option backward.isDefEq.respectTransparency false
+
+variable (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+  (words : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+  (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+theorem expectedMonitoredPayment_counter_lower (counter : MonitoredState inputs → ENNReal)
+    (charge : (OracleWorld + SigningSpec).Domain → CertificateMonitorState → ENNReal)
+    (hstep : ∀ input state, MonitoredValid inputs state → requestInputs key input ⊆ inputs →
+      counter state + charge input (monitorView state) ≤
+        ∑' result, Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] * counter result.2)
+    {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : MonitoredState inputs) (hvalid : MonitoredValid inputs state) (hinputs : sourceInputs key computation ⊆ inputs) :
+    counter state + expectedMonitoredPayment key inputs hencoding words publicReplies selections rows budget required stopAfter charge computation state ≤
+      ∑' result, Pr[= result | monitoredRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state] * counter result.2 := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [monitoredRun_pure, tsum_probOutput_pure_mul, expectedMonitoredPayment, construct_pure, add_zero, le_refl]
+  | query_bind input next ih =>
+      rw [monitoredRun_query_bind, tsum_probOutput_bind_mul]
+      let payment (result : Option ((OracleWorld + SigningSpec).Range input) × MonitoredState inputs) : ENNReal :=
+        result.1.elim 0 (fun answer => expectedMonitoredPayment key inputs hencoding words publicReplies selections rows budget required stopAfter charge (next answer) result.2)
+      calc
+        _ = (counter state + charge input (monitorView state)) +
+            ∑' result, Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] * payment result :=
+          (add_assoc _ _ _).symm
+        _ ≤ ∑' result, Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+            (counter result.2 + payment result) := by
+          simp only [mul_add, ENNReal.tsum_add]
+          exact add_le_add (hstep input state hvalid ((requestInputs_subset key input next).trans hinputs)) le_rfl
+        _ ≤ _ := by
+          apply ENNReal.tsum_le_tsum
+          intro result
+          by_cases hr : Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] = 0
+          · simp only [hr, zero_mul, le_refl]
+          · rw [SPMF.probOutput_eq_apply] at hr
+            have hv := monitoredStep_valid key inputs hencoding words publicReplies selections rows budget required stopAfter input state hvalid result hr
+            apply mul_le_mul' le_rfl
+            rcases result with ⟨answer, after⟩
+            cases answer with
+            | none => simp only [payment, Option.elim_none, tsum_probOutput_pure_mul, add_zero, le_refl]
+            | some answer => exact ih answer after hv ((sourceInputs_next_subset key input next answer).trans hinputs)
+
+theorem expectedMonitoredPayment_mul
+    (charge : (OracleWorld + SigningSpec).Domain → CertificateMonitorState → ENNReal) (rate : ENNReal)
+    {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result) (state : MonitoredState inputs) :
+    expectedMonitoredPayment key inputs hencoding words publicReplies selections rows budget required stopAfter
+      (fun input current => charge input current * rate) computation state =
+      expectedMonitoredPayment key inputs hencoding words publicReplies selections rows budget required stopAfter charge computation state * rate := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => exact (zero_mul _).symm
+  | query_bind input next ih =>
+      change charge input (monitorView state) * rate +
+        (∑' result, Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+          result.1.elim 0 (fun answer => expectedMonitoredPayment key inputs hencoding words publicReplies selections rows budget required stopAfter
+            (fun input current => charge input current * rate) (next answer) result.2)) =
+        (charge input (monitorView state) +
+          ∑' result, Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+            result.1.elim 0 (fun answer => expectedMonitoredPayment key inputs hencoding words publicReplies selections rows budget required stopAfter charge (next answer) result.2)) * rate
+      rw [add_mul, ← ENNReal.tsum_mul_right]
+      apply congrArg₂ (· + ·) rfl
+      apply tsum_congr
+      rintro ⟨answer, after⟩
+      cases answer with
+      | none => simp only [Option.elim_none, mul_zero, zero_mul]
+      | some answer => simp only [Option.elim_some, ih, mul_assoc]
+
+theorem expectedMonitoredPayment_le_budget {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : MonitoredState inputs) (hvalid : MonitoredValid inputs state) (hinputs : sourceInputs key computation ⊆ inputs)
+    (q : Nat) (hq : ∀ result, monitoredRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state result ≠ 0 →
+      result.2.1.memory.external.hashCalls ≤ q) :
+    expectedMonitoredPayment key inputs hencoding words publicReplies selections rows budget required stopAfter (nativeMessageCharge key) computation state ≤ q := by
+  apply le_trans (le_add_self.trans (expectedMonitoredPayment_counter_lower key inputs hencoding words publicReplies selections rows budget required stopAfter
+    (fun current => (current.1.memory.external.hashCalls : ENNReal)) (nativeMessageCharge key)
+    (expected_monitoredStep_hashCalls_lower key inputs hencoding words publicReplies selections rows budget required stopAfter) computation state hvalid hinputs))
+  calc
+    _ ≤ ∑' result, Pr[= result | monitoredRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state] * (q : ENNReal) := by
+      apply ENNReal.tsum_le_tsum
+      intro result
+      by_cases hr : Pr[= result | monitoredRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state] = 0
+      · simp only [hr, zero_mul, le_refl]
+      · exact mul_le_mul' le_rfl (Nat.cast_le.mpr (hq result hr))
+    _ ≤ _ := by
+      rw [ENNReal.tsum_mul_right]
+      exact mul_le_of_le_one_left' tsum_probOutput_le_one
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualPrimitivePotential.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualPrimitivePotential.lean
new file mode 100644
index 000000000..07e224b6b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualPrimitivePotential.lean
@@ -0,0 +1,553 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualCandidateHistory
+import SphincsSecurity.Proof.Residual.RetainedResidualEncodingHistory
+import SphincsSecurity.Proof.Residual.RetainedResidualQueryPotential
+import SphincsSecurity.Proof.Residual.RetainedResidualTerminalCoverage
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs sourceInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def primitiveContinuation (budget : Nat) (memory : Memory) : ENNReal :=
+  ENNReal.ofReal (PrimitiveMessagePotential.value (2 ^ digestBits) memory.external.probes
+    ((budget : ℝ) - memory.external.hashCalls))
+
+noncomputable def primitiveLivePotential (budget : Nat) (memory : Memory) : ENNReal :=
+  (memory.messageCalls.length : ENNReal) / 2 ^ digestBits + primitiveContinuation budget memory
+
+noncomputable def primitiveResultPotential {Result : Type} {inputs : Finset HashInput}
+    (budget : Nat) (result : Option Result × State inputs) : ENNReal :=
+  (result.2.memory.messageCalls.length : ENNReal) / 2 ^ digestBits +
+    result.1.elim 1 (fun _ => primitiveContinuation budget result.2.memory)
+
+theorem primitiveLivePotential_applyBoundary_le (budget : Nat) (memory : Memory) (trace : SigningBoundaryTrace)
+    (hresources : ProbeMessageBound memory) (hcost : memory.external.hashCalls + trace.hashCalls ≤ budget)
+    (hbudget : 2 * budget ≤ 2 ^ digestBits) :
+    primitiveLivePotential budget (memory.applyBoundary trace) ≤ primitiveLivePotential budget memory := by
+  have hp : (memory.external.probes : ℝ) ≤ memory.external.hashCalls := by
+    exact_mod_cast (show memory.external.probes ≤ memory.external.hashCalls from
+      (Nat.le_add_right _ _).trans hresources)
+  have hc : (memory.external.hashCalls : ℝ) + trace.hashCalls ≤ budget := by exact_mod_cast hcost
+  have hb : 2 * (budget : ℝ) ≤ 2 ^ digestBits := by exact_mod_cast hbudget
+  have hr : (0 : ℝ) ≤ budget - (memory.external.hashCalls + trace.hashCalls) := by linarith
+  have hs : (0 : ℝ) < 2 ^ digestBits := by positivity
+  have hpay := PrimitiveMessagePotential.work_payment (2 ^ digestBits) memory.external.probes
+    ((budget : ℝ) - (memory.external.hashCalls + trace.hashCalls)) trace.messageCalls.length trace.hashCalls hs
+    (by positivity) hr (List.length_filterMap_le _ _) (by linarith)
+  have hrestore : (budget : ℝ) - (memory.external.hashCalls + trace.hashCalls) + trace.hashCalls =
+      budget - memory.external.hashCalls := by ring
+  rw [hrestore] at hpay
+  have hbounds := PrimitiveMessagePotential.bounds (2 ^ digestBits) memory.external.probes
+    ((budget : ℝ) - (memory.external.hashCalls + trace.hashCalls)) hr (by linarith)
+  have hpayment := ENNReal.ofReal_le_ofReal hpay
+  rw [ENNReal.ofReal_add (by positivity) hbounds.1, ENNReal.ofReal_div_of_pos hs,
+    ENNReal.ofReal_natCast] at hpayment
+  norm_num only [ENNReal.ofReal_pow (by norm_num : (0 : ℝ) ≤ 2), ENNReal.ofReal_ofNat] at hpayment
+  change (memory.messageCalls ++ trace.messageCalls).length / (2 ^ digestBits : ENNReal) +
+      ENNReal.ofReal (PrimitiveMessagePotential.value (2 ^ digestBits) memory.external.probes
+        ((budget : ℝ) - (memory.external.hashCalls + trace.hashCalls : Nat))) ≤ _
+  rw [List.length_append, Nat.cast_add, ENNReal.add_div, Nat.cast_add, add_assoc]
+  exact add_le_add le_rfl hpayment
+
+theorem primitiveLivePotential_recordSigning (budget : Nat) (memory : Memory) (message : Message) (record : SigningRecord) :
+    primitiveLivePotential budget (memory.recordSigning message record) = primitiveLivePotential budget memory := rfl
+
+private theorem expected_indicator_value_le {Result : Type} (law : SPMF Result) (event : Result → Prop) [DecidablePred event]
+    (cost value : ENNReal) :
+    (∑' result, Pr[= result | law] * (cost + if event result then 1 else value)) ≤
+      cost + Pr[event | law] + (1 - Pr[event | law]) * value := by
+  have hcomplement : Pr[fun result => ¬event result | law] ≤ 1 - Pr[event | law] := by
+    apply ENNReal.le_sub_of_add_le_left probEvent_ne_top
+    rw [probEvent_compl]
+    exact tsub_le_self
+  have hsplit : (∑' result, Pr[= result | law] * (if event result then 1 else value)) =
+      Pr[event | law] + Pr[fun result => ¬event result | law] * value := by
+    rw [probEvent_eq_tsum_ite, probEvent_eq_tsum_ite, ← ENNReal.tsum_mul_right, ← ENNReal.tsum_add]
+    apply tsum_congr
+    intro result
+    by_cases he : event result <;> simp [he]
+  simp only [mul_add, ENNReal.tsum_add]
+  rw [hsplit, ENNReal.tsum_mul_right, ← add_assoc]
+  exact add_le_add (add_le_add (mul_le_of_le_one_left' tsum_probOutput_le_one) le_rfl)
+    (mul_le_mul' hcomplement le_rfl)
+
+private theorem ennreal_mixture_le (probability : ENNReal) (hprobability : probability ≤ 1)
+    (value bound : ℝ) (hvalue : 0 ≤ value) (hbound : 0 ≤ bound)
+    (h : probability.toReal + (1 - probability.toReal) * value ≤ bound) :
+    probability + (1 - probability) * ENNReal.ofReal value ≤ ENNReal.ofReal bound := by
+  have hp : probability ≠ ⊤ := ne_top_of_le_ne_top (by simp) hprobability
+  have hs : 1 - probability ≠ ⊤ := ne_top_of_le_ne_top (by simp) tsub_le_self
+  apply (ENNReal.toReal_le_toReal (ENNReal.add_ne_top.mpr ⟨hp, ENNReal.mul_ne_top hs ENNReal.ofReal_ne_top⟩)
+    ENNReal.ofReal_ne_top).mp
+  rw [ENNReal.toReal_add hp (ENNReal.mul_ne_top hs ENNReal.ofReal_ne_top), ENNReal.toReal_mul,
+    ENNReal.toReal_sub_of_le hprobability (by simp), ENNReal.toReal_one,
+    ENNReal.toReal_ofReal hvalue, ENNReal.toReal_ofReal hbound]
+  exact h
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+  (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem lazyByteRun_hash_jointPotential (routing : Routing) (input : HashInput) (hin : input ∈ inputs)
+    (state : State inputs) (budget : Nat)
+    (hselect : ∀ position, FirstSuccessTable.select decodeEncodingOutput (fun counter => rows (position, counter)) = selections position)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hcandidates : ResidualByteFrontend.HiddenCandidateBound words routing.disclosed (project state))
+    (hclean : ResidualByteFrontend.ReplyClean
+      (PublicEncodingMatch.Match parameter (knownEncodingMessage routing.known) words selections) state.memory.external.cache)
+    (hresources : ProbeMessageBound state.memory) (hquery : state.memory.external.hashCalls + 1 ≤ budget)
+    (hbudget : 2 * budget ≤ 2 ^ digestBits) :
+    (∑' result, Pr[= result | lazyByteRun parameter inputs hencoding words publicReplies selections rows routing
+        (liftM (OracleWorld.query (.inr input))) state] * primitiveResultPotential budget result) ≤
+      primitiveLivePotential budget state.memory := by
+  let law := lazyByteRun parameter inputs hencoding words publicReplies selections rows routing
+    (liftM (OracleWorld.query (.inr input))) state
+  let afterProbes := (charge parameter words routing.disclosed routing.known input state.memory.external).probes
+  let nextValue := PrimitiveMessagePotential.value (2 ^ digestBits) afterProbes
+    ((budget : ℝ) - (state.memory.external.hashCalls + 1))
+  let increment : ℝ := if FtsProbeSimulation.MessageHashInput parameter input then (2 ^ digestBits : ℝ)⁻¹ else 0
+  have hlaw : law = lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+      (simulateQ (embed inputs routing)
+        (ResidualByteFrontend.checkedHashQuery
+          (PublicEncodingMatch.Match parameter (knownEncodingMessage routing.known) words selections) ⟨input, hin⟩)) state := by
+    simp only [law, lazyByteRun, simulateQ_spec_query, ResidualByteFrontend.checkedTranslate, dif_pos hin]
+  have hp : (state.memory.external.probes : ℝ) ≤ state.memory.external.hashCalls := by
+    exact_mod_cast (show state.memory.external.probes ≤ state.memory.external.hashCalls from
+      (Nat.le_add_right _ _).trans hresources)
+  have hc : (state.memory.external.hashCalls : ℝ) + 1 ≤ budget := by exact_mod_cast hquery
+  have hb : 2 * (budget : ℝ) ≤ 2 ^ digestBits := by exact_mod_cast hbudget
+  have hs : (0 : ℝ) < 2 ^ digestBits := by positivity
+  have hap : (afterProbes : ℝ) ≤ state.memory.external.probes + 1 := by
+    exact_mod_cast charge_probes_le parameter words routing.disclosed routing.known input state.memory.external
+  have hn : 0 ≤ nextValue := (PrimitiveMessagePotential.bounds (2 ^ digestBits) afterProbes
+    ((budget : ℝ) - (state.memory.external.hashCalls + 1)) (by linarith) (by linarith)).1
+  have hi : 0 ≤ increment := by unfold increment; split <;> positivity
+  have hbefore := (PrimitiveMessagePotential.bounds (2 ^ digestBits) state.memory.external.probes
+    ((budget : ℝ) - state.memory.external.hashCalls) (by linarith) (by linarith)).1
+  have hscalar := checkedHashQuery_joint_payment parameter inputs hencoding words publicReplies selections rows routing
+    ⟨input, hin⟩ state budget hselect ha hcovered hcandidates hclean hresources hquery hbudget
+  dsimp only at hscalar
+  rw [← hlaw] at hscalar
+  change (Pr[fun result => result.1 = none | law]).toReal +
+    (1 - (Pr[fun result => result.1 = none | law]).toReal) * (increment + nextValue) ≤ _ at hscalar
+  have hpayment := ennreal_mixture_le (Pr[fun result => result.1 = none | law]) probEvent_le_one _ _
+    (add_nonneg hi hn) hbefore hscalar
+  change (∑' result, Pr[= result | law] * primitiveResultPotential budget result) ≤ _
+  calc
+    _ ≤ ∑' result, Pr[= result | law] *
+        ((state.memory.messageCalls.length : ENNReal) / 2 ^ digestBits +
+          if result.1 = none then 1 else ENNReal.ofReal (increment + nextValue)) := by
+      apply ENNReal.tsum_le_tsum
+      intro result
+      by_cases hr : Pr[= result | law] = 0
+      · simp only [hr, zero_mul, le_refl]
+      · apply mul_le_mul' le_rfl
+        obtain ⟨actual, seed, heq⟩ := lazyByteRun_hash_result parameter inputs hencoding words publicReplies selections rows
+          routing input hin state ha result hr
+        have hhash := checkedHashResult_hashCalls parameter inputs hencoding words publicReplies selections rows routing actual seed ⟨input, hin⟩ state
+        have hprobes := checkedHashResult_probes parameter inputs hencoding words publicReplies selections rows routing actual seed ⟨input, hin⟩ state
+        have hmemory := checkedHashResult_memory parameter inputs hencoding words publicReplies selections rows routing actual seed ⟨input, hin⟩ state
+        rw [← heq] at hhash hprobes hmemory
+        have hmessages := congrArg (fun memory : Memory => memory.messageCalls.length) hmemory
+        by_cases hnone : result.1 = none
+        · simp only [hnone, Memory.afterReply, Option.elim_none] at hmessages
+          simp only [primitiveResultPotential, hnone, Option.elim_none, hmessages, if_pos, le_refl]
+        · obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp hnone
+          simp only [hanswer, Memory.afterReply, Option.elim_some, Memory.observeMessage] at hmessages
+          simp only [primitiveResultPotential, hanswer, Option.elim_some, reduceCtorEq, if_false,
+            primitiveContinuation, hhash, Nat.cast_add, Nat.cast_one, hprobes]
+          by_cases hm : FtsProbeSimulation.MessageHashInput parameter input
+          · simp only [if_pos hm, List.length_append, List.length_singleton] at hmessages
+            rw [hmessages, Nat.cast_add, Nat.cast_one, ENNReal.add_div, add_assoc]
+            unfold increment
+            rw [if_pos hm, ENNReal.ofReal_add (by positivity) hn]
+            simp only [one_div, ENNReal.ofReal_inv_of_pos hs,
+              ENNReal.ofReal_pow (by norm_num : (0 : ℝ) ≤ 2), ENNReal.ofReal_ofNat, nextValue, afterProbes, le_refl]
+          · simp only [if_neg hm] at hmessages
+            rw [hmessages]
+            simp only [increment, if_neg hm, zero_add, nextValue, afterProbes, le_refl]
+    _ ≤ (state.memory.messageCalls.length : ENNReal) / 2 ^ digestBits +
+        (Pr[fun result => result.1 = none | law] +
+          (1 - Pr[fun result => result.1 = none | law]) * ENNReal.ofReal (increment + nextValue)) := by
+      simpa only [add_assoc] using expected_indicator_value_le law (fun result => result.1 = none)
+        ((state.memory.messageCalls.length : ENNReal) / 2 ^ digestBits) (ENNReal.ofReal (increment + nextValue))
+    _ ≤ _ := add_le_add le_rfl hpayment
+
+omit parameter hencoding in
+theorem lazyRun_signingProgram_jointPotential (key : SecretKey)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (message : Message)
+    (hinputs : hashInputs (signWithView key message) ⊆ inputs) (state : State inputs) (budget : Nat)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) (hresources : ProbeMessageBound state.memory)
+    (hbudget : 2 * budget ≤ 2 ^ digestBits)
+    (hcost : ∀ result, lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+      (signingProgram inputs key.parameter key.root words selections message) state result ≠ 0 →
+        result.2.memory.external.hashCalls ≤ budget) :
+    (∑' result, Pr[= result | lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+        (signingProgram inputs key.parameter key.root words selections message) state] * primitiveResultPotential budget result) ≤
+      primitiveLivePotential budget state.memory := by
+  calc
+    _ ≤ ∑' result, Pr[= result | lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+        (signingProgram inputs key.parameter key.root words selections message) state] * primitiveLivePotential budget state.memory := by
+      apply ENNReal.tsum_le_tsum
+      intro result
+      by_cases hr : Pr[= result | lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+          (signingProgram inputs key.parameter key.root words selections message) state] = 0
+      · simp only [hr, zero_mul, le_refl]
+      · apply mul_le_mul' le_rfl
+        have hc := hcost result hr
+        rw [SPMF.probOutput_eq_apply] at hr
+        rw [lazyRun_signingProgram key inputs hencoding words publicReplies selections rows message state,
+          map_eq_bind_pure_comp] at hr
+        obtain ⟨raw, hraw, hr⟩ := (RetainedObservation.bind_nonzero _ _ _).mp hr
+        have hloop := (ResidualByteFrontend.hashInputs_publicSigningWork_subset_signWithView key
+          state.memory.routing.known words selections message).trans hinputs
+        rw [ResidualByteFrontend.hashInputs_publicSigningWork] at hloop
+        obtain ⟨record, hrecord, hmemory⟩ := lazyRun_jointSigningProgram_memory_trace key.parameter inputs hencoding words publicReplies selections rows
+          state.memory.routing key.root message hloop state ha hcovered raw hraw
+        simp only [Function.comp_def, hrecord, Option.elim_some, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+        subst result
+        change primitiveLivePotential budget (raw.2.memory.recordSigning message record) ≤ _
+        rw [primitiveLivePotential_recordSigning, hmemory]
+        change raw.2.memory.external.hashCalls ≤ budget at hc
+        rw [hmemory] at hc
+        exact primitiveLivePotential_applyBoundary_le budget state.memory record.2 hresources hc hbudget
+    _ ≤ _ := by
+      rw [ENNReal.tsum_mul_right]
+      exact mul_le_of_le_one_left' tsum_probOutput_le_one
+
+theorem lazyByteRun_world_jointPotential (routing : Routing) (input : OracleWorld.Domain)
+    (hinputs : hashInputs (liftM (OracleWorld.query input)) ⊆ inputs) (state : State inputs) (budget : Nat)
+    (hselect : ∀ position, FirstSuccessTable.select decodeEncodingOutput (fun counter => rows (position, counter)) = selections position)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hcandidates : ResidualByteFrontend.HiddenCandidateBound words routing.disclosed (project state))
+    (hclean : ResidualByteFrontend.ReplyClean
+      (PublicEncodingMatch.Match parameter (knownEncodingMessage routing.known) words selections) state.memory.external.cache)
+    (hresources : ProbeMessageBound state.memory)
+    (hquery : state.memory.external.hashCalls + (if input matches .inr _ then 1 else 0) ≤ budget)
+    (hbudget : 2 * budget ≤ 2 ^ digestBits) :
+    (∑' result, Pr[= result | lazyByteRun parameter inputs hencoding words publicReplies selections rows routing
+        (liftM (OracleWorld.query input)) state] * primitiveResultPotential budget result) ≤
+      primitiveLivePotential budget state.memory := by
+  cases input with
+  | inr input =>
+      have hin : input ∈ inputs := hinputs (by
+        simpa only [bind_pure] using mem_hashInputs_hash_bind input pure)
+      exact lazyByteRun_hash_jointPotential parameter inputs hencoding words publicReplies selections rows routing input hin state budget
+        hselect ha hcovered hcandidates hclean hresources hquery hbudget
+  | inl input =>
+      rw [← bind_pure (liftM (OracleWorld.query (.inl input))), lazyByteRun_random_bind, tsum_probOutput_bind_mul]
+      simp only [lazyByteRun_pure, tsum_probOutput_pure_mul, primitiveResultPotential, Option.elim_some]
+      rw [ENNReal.tsum_mul_right]
+      exact mul_le_of_le_one_left' tsum_probOutput_le_one
+
+theorem lazyRun_supported_result {Result : Type} (computation : OracleComp (World inputs) Result)
+    (state : State inputs) (ha : ∀ coordinate, (state.candidates coordinate).Nonempty) :
+    ∃ result, lazyRun (environment parameter inputs hencoding words publicReplies selections rows) computation state result ≠ 0 := by
+  have h := lazyRun_bind_const (environment parameter inputs hencoding words publicReplies selections rows) computation state ha
+    (pure () : SPMF Unit)
+  have hh := congrArg (fun law : SPMF Unit => Pr[= () | law]) h
+  simp only [probOutput_bind_eq_tsum, probOutput_pure_self, mul_one] at hh
+  by_contra hn
+  simp only [not_exists, not_not] at hn
+  simp only [SPMF.probOutput_eq_apply, hn, tsum_zero] at hh
+  exact zero_ne_one hh
+
+omit parameter hencoding in
+theorem lazyRun_request_jointPotential (key : SecretKey)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (input : (OracleWorld + SigningSpec).Domain)
+    (hinputs : requestInputs key input ⊆ inputs) (state : State inputs) (budget : Nat)
+    (hselect : ∀ position, FirstSuccessTable.select decodeEncodingOutput (fun counter => rows (position, counter)) = selections position)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hcandidates : ResidualByteFrontend.HiddenCandidateBound words state.memory.routing.disclosed (project state))
+    (hclean : ResidualByteFrontend.ReplyClean
+      (PublicEncodingMatch.Match key.parameter (knownEncodingMessage state.memory.routing.known) words selections) state.memory.external.cache)
+    (hresources : ProbeMessageBound state.memory) (hbudget : 2 * budget ≤ 2 ^ digestBits)
+    (hcost : ∀ result, lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+      (adversaryImpl inputs key.parameter key.root words selections input) state result ≠ 0 →
+        result.2.memory.external.hashCalls ≤ budget) :
+    (∑' result, Pr[= result | lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+        (adversaryImpl inputs key.parameter key.root words selections input) state] * primitiveResultPotential budget result) ≤
+      primitiveLivePotential budget state.memory := by
+  cases input with
+  | inr message =>
+      exact lazyRun_signingProgram_jointPotential inputs words publicReplies selections rows key hencoding message hinputs state budget
+        ha hcovered hresources hbudget hcost
+  | inl input =>
+      obtain ⟨result, hr⟩ := lazyRun_supported_result key.parameter inputs hencoding words publicReplies selections rows
+        (adversaryImpl inputs key.parameter key.root words selections (.inl input)) state ha
+      have hc := hcost result hr
+      change lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+        (externalProgram inputs key.parameter words selections (liftM (OracleWorld.query input))) state result ≠ 0 at hr
+      rw [lazyRun_externalProgram] at hr
+      have hh := lazyByteRun_world_hashCalls key.parameter inputs hencoding words publicReplies selections rows
+        state.memory.routing input hinputs state ha result hr
+      rw [hh] at hc
+      change (∑' result, Pr[= result | lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+        (externalProgram inputs key.parameter words selections (liftM (OracleWorld.query input))) state] * primitiveResultPotential budget result) ≤ _
+      rw [lazyRun_externalProgram]
+      exact lazyByteRun_world_jointPotential key.parameter inputs hencoding words publicReplies selections rows state.memory.routing input
+        hinputs state budget hselect ha hcovered hcandidates hclean hresources (by cases input <;> exact hc) hbudget
+
+omit parameter hencoding in
+theorem lazyRun_request_hashCalls_mono (key : SecretKey)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (input : (OracleWorld + SigningSpec).Domain)
+    (hinputs : requestInputs key input ⊆ inputs) (state : State inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (result : Option ((OracleWorld + SigningSpec).Range input) × State inputs)
+    (hresult : lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+      (adversaryImpl inputs key.parameter key.root words selections input) state result ≠ 0) :
+    state.memory.external.hashCalls ≤ result.2.memory.external.hashCalls := by
+  cases input with
+  | inl input =>
+      change lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+        (externalProgram inputs key.parameter words selections (liftM (OracleWorld.query input))) state result ≠ 0 at hresult
+      rw [lazyRun_externalProgram] at hresult
+      rw [lazyByteRun_world_hashCalls key.parameter inputs hencoding words publicReplies selections rows
+        state.memory.routing input hinputs state ha result hresult]
+      exact Nat.le_add_right _ _
+  | inr message =>
+      change lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+        (signingProgram inputs key.parameter key.root words selections message) state result ≠ 0 at hresult
+      rw [lazyRun_signingProgram key inputs hencoding words publicReplies selections rows message state,
+        map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨raw, hraw, hresult⟩ := hresult
+      have hloop := (ResidualByteFrontend.hashInputs_publicSigningWork_subset_signWithView key
+        state.memory.routing.known words selections message).trans hinputs
+      rw [ResidualByteFrontend.hashInputs_publicSigningWork] at hloop
+      obtain ⟨record, hrecord, hmemory⟩ := lazyRun_jointSigningProgram_memory_trace key.parameter inputs hencoding words publicReplies selections rows
+        state.memory.routing key.root message hloop state ha hcovered raw hraw
+      simp only [Function.comp_def, hrecord, Option.elim_some, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      change state.memory.external.hashCalls ≤ raw.2.memory.external.hashCalls
+      rw [hmemory]
+      exact Nat.le_add_right _ _
+
+omit parameter hencoding in
+theorem lazyRun_source_hashCalls_mono {Result : Type} (key : SecretKey)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) (hinputs : sourceInputs key computation ⊆ inputs)
+    (state : State inputs) (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) (result : Option Result × State inputs)
+    (hresult : lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+      (simulateQ (adversaryImpl inputs key.parameter key.root words selections) computation) state result ≠ 0) :
+    state.memory.external.hashCalls ≤ result.2.memory.external.hashCalls := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      simp only [simulateQ_pure, lazyRun, runWith_pure, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact le_rfl
+  | query_bind input next ih =>
+      rw [simulateQ_bind, simulateQ_spec_query, lazyRun_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨middle, hmiddle, hresult⟩ := hresult
+      have hm := lazyRun_request_hashCalls_mono inputs words publicReplies selections rows key hencoding input
+        ((requestInputs_subset key input next).trans hinputs) state ha hcovered middle hmiddle
+      have ha' := lazyRun_nonempty (environment key.parameter inputs hencoding words publicReplies selections rows) _ state ha middle hmiddle
+      have hc' := lazyRun_rowsCovered key.parameter inputs hencoding words publicReplies selections rows _ state ha hcovered middle hmiddle
+      rcases middle with ⟨answer, after⟩
+      cases answer with
+      | none =>
+          simp only [Option.elim_none, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          subst result
+          exact hm
+      | some answer =>
+          exact hm.trans (ih answer ((sourceInputs_next_subset key input next answer).trans hinputs) after ha' hc' result hresult)
+
+omit parameter hencoding in
+theorem lazyRun_source_jointPotential {Result : Type} (key : SecretKey)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) (hinputs : sourceInputs key computation ⊆ inputs)
+    (state : State inputs) (budget : Nat)
+    (hselect : ∀ position, FirstSuccessTable.select decodeEncodingOutput (fun counter => rows (position, counter)) = selections position)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hcandidates : ResidualByteFrontend.HiddenCandidateBound words state.memory.routing.disclosed (project state))
+    (hclean : ResidualByteFrontend.ReplyClean
+      (PublicEncodingMatch.Match key.parameter (knownEncodingMessage state.memory.routing.known) words selections) state.memory.external.cache)
+    (hresources : ProbeMessageBound state.memory) (hbudget : 2 * budget ≤ 2 ^ digestBits)
+    (hcost : ∀ result, lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+      (simulateQ (adversaryImpl inputs key.parameter key.root words selections) computation) state result ≠ 0 →
+        result.2.memory.external.hashCalls ≤ budget) :
+    (∑' result, Pr[= result | lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+        (simulateQ (adversaryImpl inputs key.parameter key.root words selections) computation) state] * primitiveResultPotential budget result) ≤
+      primitiveLivePotential budget state.memory := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value =>
+      simp only [simulateQ_pure, lazyRun, runWith_pure, tsum_probOutput_pure_mul,
+        primitiveResultPotential, Option.elim_some, primitiveLivePotential, le_refl]
+  | query_bind input next ih =>
+      have hin := (requestInputs_subset key input next).trans hinputs
+      have hnext : ∀ answer, sourceInputs key (next answer) ⊆ inputs :=
+        fun answer => (sourceInputs_next_subset key input next answer).trans hinputs
+      have hjoined (middle : Option ((OracleWorld + SigningSpec).Range input) × State inputs)
+          (hmiddle : lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+            (adversaryImpl inputs key.parameter key.root words selections input) state middle ≠ 0)
+          (result : Option Result × State inputs)
+          (hresult : middle.1.elim (pure (none, middle.2)) (fun answer =>
+            lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+              (simulateQ (adversaryImpl inputs key.parameter key.root words selections) (next answer)) middle.2) result ≠ 0) :
+          result.2.memory.external.hashCalls ≤ budget := by
+        apply hcost result
+        rw [simulateQ_bind, simulateQ_spec_query, lazyRun_bind, RetainedObservation.bind_nonzero]
+        exact ⟨middle, hmiddle, hresult⟩
+      have hstepcost (middle : Option ((OracleWorld + SigningSpec).Range input) × State inputs)
+          (hmiddle : lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+            (adversaryImpl inputs key.parameter key.root words selections input) state middle ≠ 0) :
+          middle.2.memory.external.hashCalls ≤ budget := by
+        have ha' := lazyRun_nonempty (environment key.parameter inputs hencoding words publicReplies selections rows) _ state ha middle hmiddle
+        have hc' := lazyRun_rowsCovered key.parameter inputs hencoding words publicReplies selections rows _ state ha hcovered middle hmiddle
+        rcases middle with ⟨answer, after⟩
+        cases answer with
+        | none => exact hjoined (none, after) hmiddle (none, after) (by simp)
+        | some answer =>
+            obtain ⟨result, hr⟩ := lazyRun_supported_result key.parameter inputs hencoding words publicReplies selections rows
+              (simulateQ (adversaryImpl inputs key.parameter key.root words selections) (next answer)) after ha'
+            exact (lazyRun_source_hashCalls_mono inputs words publicReplies selections rows key hencoding (next answer)
+              (hnext answer) after ha' hc' result hr).trans (hjoined (some answer, after) hmiddle result hr)
+      apply le_trans ?_ (lazyRun_request_jointPotential inputs words publicReplies selections rows key hencoding input hin state budget
+        hselect ha hcovered hcandidates hclean hresources hbudget hstepcost)
+      rw [simulateQ_bind, simulateQ_spec_query, lazyRun_bind, tsum_probOutput_bind_mul]
+      apply ENNReal.tsum_le_tsum
+      intro middle
+      by_cases hm : Pr[= middle | lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+          (adversaryImpl inputs key.parameter key.root words selections input) state] = 0
+      · simp only [hm, zero_mul, le_refl]
+      · apply mul_le_mul' le_rfl
+        have ha' := lazyRun_nonempty (environment key.parameter inputs hencoding words publicReplies selections rows) _ state ha middle hm
+        have hc' := lazyRun_rowsCovered key.parameter inputs hencoding words publicReplies selections rows _ state ha hcovered middle hm
+        have hp' := lazyRun_request_hiddenCandidateBound key inputs hencoding words publicReplies selections rows input hin state
+          ha hcovered hcandidates middle hm
+        have hr' := lazyRun_request_probeMessageBound inputs words publicReplies selections rows key hencoding input hin state
+          ha hcovered hresources middle hm
+        rcases middle with ⟨answer, after⟩
+        cases answer with
+        | none => simp only [Option.elim_none, tsum_probOutput_pure_mul, primitiveResultPotential, Option.elim_none, le_refl]
+        | some answer =>
+            have he' := lazyRun_request_encodingClean inputs words publicReplies selections rows key hencoding input hin state
+              ha hcovered hclean (some answer, after) hm (by simp)
+            exact ih answer (hnext answer) after ha' hc' hp' he' hr' (hjoined (some answer, after) hm)
+
+theorem stop_add_messages_le_expected_primitivePotential {Result : Type} {inputs : Finset HashInput}
+    (budget : Nat) (law : SPMF (Option Result × State inputs)) :
+    Pr[fun result => result.1 = none | law] +
+      (∑' result, Pr[= result | law] * (result.2.memory.messageCalls.length : ENNReal)) / 2 ^ digestBits ≤
+        ∑' result, Pr[= result | law] * primitiveResultPotential budget result := by
+  rw [probEvent_eq_tsum_ite, div_eq_mul_inv, ← ENNReal.tsum_mul_right, ← ENNReal.tsum_add]
+  apply ENNReal.tsum_le_tsum
+  intro result
+  rw [primitiveResultPotential, mul_add, div_eq_mul_inv, mul_assoc, add_comm]
+  apply add_le_add le_rfl
+  cases result.1 with
+  | none => simp only [if_pos, Option.elim_none, mul_one, le_refl]
+  | some answer => simp only [reduceCtorEq, if_false, zero_le]
+
+theorem primitiveLivePotential_initial_le (inputs : Finset HashInput) (words : OtsReferenceWords)
+    (exposed : InitialPublicLabels words) (budget : Nat) (hcost : 1212415 ≤ budget)
+    (hbudget : 2 * budget ≤ 2 ^ digestBits) :
+    primitiveLivePotential budget (initialState inputs words exposed).memory ≤
+      ENNReal.ofReal (2 * ((budget : ℝ) / 2 ^ digestBits) - ((budget : ℝ) / 2 ^ digestBits) ^ 2) := by
+  have hc : (1212415 : ℝ) ≤ budget := by exact_mod_cast hcost
+  have hb : 2 * (budget : ℝ) ≤ 2 ^ digestBits := by exact_mod_cast hbudget
+  have hs : (0 : ℝ) < 2 ^ digestBits := by positivity
+  have hm := PrimitiveMessagePotential.mono_remaining (2 ^ digestBits) 0 ((budget : ℝ) - 1212415) budget
+    (by linarith) (by linarith) (by linarith)
+  rw [PrimitiveMessagePotential.initial _ (budget : ℝ) hs.ne'] at hm
+  simpa only [primitiveLivePotential, primitiveContinuation, initialState, initialMemory, List.length_nil,
+    Nat.cast_zero, Nat.cast_ofNat, ENNReal.zero_div, zero_add] using ENNReal.ofReal_le_ofReal hm
+
+omit parameter inputs hencoding words publicReplies selections rows in
+theorem initialMonitoredSource_joint_primitive_messages (key : SecretKey) (adversary : Adversary)
+    (encoding : ReferenceEncodingAuxiliary) (dummy : OtsReferenceWords)
+    (exposed : InitialPublicLabels (referenceFamilyWords encoding.selections dummy)) (high : CanonicalGraphHighHalves)
+    (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule) (stopped : Bool)
+    (hparameter : key.parameter ∈ support sampleParameter)
+    (hencoding : encoding ∈ referenceEncodingAuxiliarySample.support)
+    (hroot : key.root = knownRoot (initialKnown (referenceFamilyWords encoding.selections dummy) exposed))
+    (hcost : HasHashQueryBound scheme adversary budget) (hbudget : budget ≤ 2 ^ 127) :
+    Pr[fun result => result.1 = none | initialMonitoredSource key adversary encoding dummy exposed high budget required stopAfter stopped] +
+      (∑' result, Pr[= result | initialMonitoredSource key adversary encoding dummy exposed high budget required stopAfter stopped] *
+        (result.2.1.memory.messageCalls.length : ENNReal)) / 2 ^ digestBits ≤
+      ENNReal.ofReal (2 * ((budget : ℝ) / 2 ^ digestBits) - ((budget : ℝ) / 2 ^ digestBits) ^ 2) := by
+  let inputs := gameInputs adversary
+  let words := referenceFamilyWords encoding.selections dummy
+  let publicReplies := coordinateGraphLabels (initialKnown words exposed) high
+  let source := FtsProbeSimulation.unloggedRetainedRestComputation adversary ⟨key.root, key.parameter⟩
+  let initial := initialState inputs words exposed
+  let env := environment key.parameter inputs (canonicalEncodingInputs_subset_retainedGameInputs adversary key.parameter)
+    words publicReplies encoding.selections encoding.rows
+  let computation := simulateQ (adversaryImpl inputs key.parameter key.root words encoding.selections) source
+  let native := lazyRun env computation initial
+  have herasure : (fun result => (result.1, result.2.1)) <$>
+      initialMonitoredSource key adversary encoding dummy exposed high budget required stopAfter stopped = native := by
+    exact monitoredRun_erasure key inputs (canonicalEncodingInputs_subset_retainedGameInputs adversary key.parameter)
+      words publicReplies encoding.selections encoding.rows budget required stopAfter source
+      (initial, initialCertificateMonitor 1212415 stopped)
+  have hnativeCost (result : Option (Forgery × Bool) × State inputs) (hr : native result ≠ 0) :
+      result.2.memory.external.hashCalls ≤ budget := by
+    rw [← herasure, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hr
+    obtain ⟨full, hfull, hr⟩ := hr
+    simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hr
+    subst result
+    exact initialMonitoredSource_hashCalls_le key adversary encoding dummy exposed high budget required stopAfter stopped
+      hparameter hencoding hroot hcost full hfull
+  have ha : ∀ coordinate, (initial.candidates coordinate).Nonempty := initialAllowed_nonempty words exposed
+  have hc : ResidualByteFrontend.RowsCovered inputs (project initial) := initialState_rowsCovered inputs words exposed
+  have hin : sourceInputs key source ⊆ inputs := sourceInputs_unlogged_subset_gameInputs adversary key
+  have hd : 2 * budget ≤ 2 ^ digestBits := by
+    norm_num only [digestBits]
+    omega
+  have hpotential := lazyRun_source_jointPotential inputs words publicReplies encoding.selections encoding.rows key
+    (canonicalEncodingInputs_subset_retainedGameInputs adversary key.parameter) source hin initial budget
+    (referenceEncodingAuxiliary_select encoding hencoding) ha hc (initialState_hiddenCandidateBound inputs words exposed)
+    (ResidualByteFrontend.replyClean_empty _) (Nat.zero_le _) hd hnativeCost
+  obtain ⟨result, hr⟩ := lazyRun_supported_result key.parameter inputs
+    (canonicalEncodingInputs_subset_retainedGameInputs adversary key.parameter) words publicReplies encoding.selections encoding.rows computation initial ha
+  have hminimum : 1212415 ≤ budget :=
+    (lazyRun_source_hashCalls_mono inputs words publicReplies encoding.selections encoding.rows key
+      (canonicalEncodingInputs_subset_retainedGameInputs adversary key.parameter) source hin initial ha hc result hr).trans (hnativeCost result hr)
+  have h := (stop_add_messages_le_expected_primitivePotential budget native).trans
+    (hpotential.trans (primitiveLivePotential_initial_le inputs words exposed budget hminimum hd))
+  rw [← herasure, probEvent_map, tsum_probOutput_map_mul] at h
+  exact h
+
+omit parameter inputs hencoding words publicReplies selections rows in
+theorem initialMonitoredSource_primitive_add_full_count_le (key : SecretKey) (adversary : Adversary)
+    (encoding : ReferenceEncodingAuxiliary) (dummy : OtsReferenceWords)
+    (exposed : InitialPublicLabels (referenceFamilyWords encoding.selections dummy)) (high : CanonicalGraphHighHalves)
+    (budget : Nat) (stopAfter : CertificateStopRule) (stopped : Bool)
+    (hparameter : key.parameter ∈ support sampleParameter)
+    (hencoding : encoding ∈ referenceEncodingAuxiliarySample.support)
+    (hroot : key.root = knownRoot (initialKnown (referenceFamilyWords encoding.selections dummy) exposed))
+    (hcost : HasHashQueryBound scheme adversary budget) (hbudget : budget ≤ 2 ^ 127) :
+    Pr[fun result => result.1 = none |
+      initialMonitoredSource key adversary encoding dummy exposed high budget Finset.univ (proposalStop stopAfter) stopped] +
+      (∑' result, Pr[= result |
+        initialMonitoredSource key adversary encoding dummy exposed high budget Finset.univ (proposalStop stopAfter) stopped] *
+          certificateBankCount result.2.2.bank) ≤
+      ENNReal.ofReal (2 * ((budget : ℝ) / 2 ^ digestBits) - ((budget : ℝ) / 2 ^ digestBits) ^ 2) +
+        (budget : ENNReal) * (11 / 2 ^ 144 : ENNReal) := by
+  let law := initialMonitoredSource key adversary encoding dummy exposed high budget Finset.univ (proposalStop stopAfter) stopped
+  let messages : ENNReal := ∑' result, Pr[= result | law] * (result.2.1.memory.messageCalls.length : ENNReal)
+  have hprimitive := initialMonitoredSource_joint_primitive_messages key adversary encoding dummy exposed high budget Finset.univ
+    (proposalStop stopAfter) stopped hparameter hencoding hroot hcost hbudget
+  have hcoverage := expected_initialMonitoredSource_full_unit_count_le key adversary encoding dummy exposed high budget
+    stopAfter stopped hparameter hencoding hroot hcost hbudget
+  calc
+    _ ≤ Pr[fun result => result.1 = none | law] +
+        ((2 ^ 128 : ENNReal)⁻¹ * messages + (budget : ENNReal) * (11 / 2 ^ 144 : ENNReal)) :=
+      add_le_add le_rfl hcoverage
+    _ = (Pr[fun result => result.1 = none | law] + messages / 2 ^ digestBits) +
+        (budget : ENNReal) * (11 / 2 ^ 144 : ENNReal) := by
+      simp only [div_eq_mul_inv, digestBits]
+      rw [mul_comm (2 ^ 128 : ENNReal)⁻¹ messages, ← add_assoc]
+    _ ≤ _ := add_le_add hprimitive le_rfl
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProbeBudget.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProbeBudget.lean
new file mode 100644
index 000000000..e0c027211
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProbeBudget.lean
@@ -0,0 +1,184 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualBoundaryCost
+import SphincsSecurity.Proof.Residual.RetainedResidualMonitoredErasure
+namespace SphincsSecurity.Concrete.ResidualByteFrontend
+
+open CanonicalProbeRouting HiddenLabelObservation ResidualByteAction
+open AdaptiveResidualLabels hiding World State Environment
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput) (words : OtsReferenceWords)
+    (disclosed : Index → FtsTree → FtsLeaf → Prop) (known : Labels) (actions : inputs → Action inputs)
+
+theorem prepare_probes (input : inputs) (memory : ExternalMemory) :
+    (prepare parameter inputs words disclosed known actions input memory).2.probes =
+      (charge parameter words disclosed known input.val memory).probes := by
+  unfold prepare
+  cases memory.cache input.val with
+  | some _ => rfl
+  | none => cases actions input <;> rfl
+
+theorem hashQueryResult_probes (actual : Labels) (seed : inputs → HashOutput) (input : inputs) (state : State inputs) :
+    (hashQueryResult parameter inputs words disclosed known actions actual seed input state).2.memory.probes =
+      (charge parameter words disclosed known input.val state.memory).probes := by
+  have h := prepare_probes parameter inputs words disclosed known actions input state.memory
+  unfold hashQueryResult
+  generalize hprepared : prepare parameter inputs words disclosed known actions input state.memory = prepared at h ⊢
+  rcases prepared with ⟨action, memory⟩
+  cases action with
+  | known answer => exact h
+  | read input => exact h
+  | probe input test =>
+      dsimp only [executeResult]
+      cases hrow : state.rows input with
+      | some answer => exact h
+      | none => dsimp only; split <;> exact h
+
+end SphincsSecurity.Concrete.ResidualByteFrontend
+
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting ResidualByteAction
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs sourceInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+def ProbeMessageBound (memory : Memory) : Prop :=
+  memory.external.probes + memory.messageCalls.length ≤ memory.external.hashCalls
+
+theorem afterReply_messageCount_le (parameter : PublicParameter) (memory : Memory) (input : HashInput)
+    (answer : Option HashOutput) (external : ExternalMemory) :
+    (memory.afterReply parameter input answer external).messageCalls.length ≤
+      memory.messageCalls.length + if FtsProbeSimulation.MessageHashInput parameter input then 1 else 0 := by
+  cases answer <;> by_cases hm : FtsProbeSimulation.MessageHashInput parameter input <;>
+    simp [Memory.afterReply, Memory.observeMessage, hm]
+
+theorem charge_message_probes (parameter : PublicParameter) (words : OtsReferenceWords) (routing : Routing)
+    (input : HashInput) (hmessage : FtsProbeSimulation.MessageHashInput parameter input) (memory : ExternalMemory) :
+    (charge parameter words routing.disclosed routing.known input memory).probes = memory.probes := by
+  have hdecode : decodePosition parameter input = none := by
+    obtain ⟨payload, hinput⟩ := hmessage
+    rw [← hinput]
+    exact decodePosition_message parameter payload
+  unfold charge
+  cases memory.cache input with
+  | some _ => rfl
+  | none => simp only [route, hdecode, Option.elim_none, Nat.add_zero]
+
+theorem applyBoundary_probeMessageBound (memory : Memory) (hbound : ProbeMessageBound memory) (trace : SigningBoundaryTrace) :
+    ProbeMessageBound (memory.applyBoundary trace) := by
+  have hlength : trace.messageCalls.length ≤ trace.hashCalls := List.length_filterMap_le _ _
+  change memory.external.probes + (memory.messageCalls ++ trace.messageCalls).length ≤ memory.external.hashCalls + trace.hashCalls
+  rw [List.length_append]
+  change memory.external.probes + memory.messageCalls.length ≤ memory.external.hashCalls at hbound
+  omega
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+  (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem checkedHashResult_probes (routing : Routing) (actual : Labels) (seed : inputs → HashOutput)
+    (input : inputs) (state : State inputs) :
+    (checkedHashResult parameter inputs hencoding words publicReplies selections rows routing actual seed input state).2.memory.external.probes =
+      (charge parameter words routing.disclosed routing.known input.val state.memory.external).probes := by
+  have hproject := congrArg (fun result : Option HashOutput × ResidualByteFrontend.State inputs => result.2.memory.probes)
+    (hashResult_project parameter inputs hencoding words publicReplies selections rows routing actual seed input state)
+  change (hashResult parameter inputs hencoding words publicReplies selections rows routing actual seed input state).2.memory.external.probes = _
+  exact hproject.trans (ResidualByteFrontend.hashQueryResult_probes parameter inputs words routing.disclosed routing.known
+    (freshPrefix parameter inputs hencoding words routing.disclosed routing.known publicReplies selections rows) actual seed input (project state))
+
+theorem checkedHashResult_probeMessageBound (routing : Routing) (actual : Labels) (seed : inputs → HashOutput)
+    (input : inputs) (state : State inputs) (hbound : ProbeMessageBound state.memory) :
+    ProbeMessageBound (checkedHashResult parameter inputs hencoding words publicReplies selections rows routing actual seed input state).2.memory := by
+  let result := checkedHashResult parameter inputs hencoding words publicReplies selections rows routing actual seed input state
+  have hp := checkedHashResult_probes parameter inputs hencoding words publicReplies selections rows routing actual seed input state
+  have hh := checkedHashResult_hashCalls parameter inputs hencoding words publicReplies selections rows routing actual seed input state
+  have hm := afterReply_messageCount_le parameter state.memory input.val result.1 result.2.memory.external
+  have hmemory := checkedHashResult_memory parameter inputs hencoding words publicReplies selections rows routing actual seed input state
+  dsimp only at hmemory
+  rw [← hmemory] at hm
+  change ProbeMessageBound result.2.memory
+  change result.2.memory.external.probes + result.2.memory.messageCalls.length ≤ result.2.memory.external.hashCalls
+  dsimp only [result] at hm ⊢
+  change state.memory.external.probes + state.memory.messageCalls.length ≤ state.memory.external.hashCalls at hbound
+  by_cases hmessage : FtsProbeSimulation.MessageHashInput parameter input.val
+  · rw [charge_message_probes parameter words routing input.val hmessage state.memory.external] at hp
+    rw [if_pos hmessage] at hm
+    omega
+  · have hp' := charge_probes_le parameter words routing.disclosed routing.known input.val state.memory.external
+    rw [if_neg hmessage] at hm
+    omega
+
+theorem lazyByteRun_world_probeMessageBound (routing : Routing) (input : OracleWorld.Domain)
+    (hinputs : hashInputs (liftM (OracleWorld.query input)) ⊆ inputs) (state : State inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty) (hbound : ProbeMessageBound state.memory)
+    (result : Option (OracleWorld.Range input) × State inputs)
+    (hresult : lazyByteRun parameter inputs hencoding words publicReplies selections rows routing
+      (liftM (OracleWorld.query input)) state result ≠ 0) : ProbeMessageBound result.2.memory := by
+  cases input with
+  | inl input =>
+      rw [← bind_pure (liftM (OracleWorld.query (.inl input))), lazyByteRun_random_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨answer, _, hresult⟩ := hresult
+      rw [lazyByteRun_pure] at hresult
+      simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact hbound
+  | inr input =>
+      have hin : input ∈ inputs := by
+        apply hinputs
+        rw [← bind_pure (liftM (OracleWorld.query (.inr input)))]
+        exact mem_hashInputs_hash_bind input pure
+      obtain ⟨actual, seed, rfl⟩ := lazyByteRun_hash_result parameter inputs hencoding words publicReplies selections rows routing input hin state ha result hresult
+      exact checkedHashResult_probeMessageBound parameter inputs hencoding words publicReplies selections rows routing actual seed ⟨input, hin⟩ state hbound
+
+omit parameter hencoding in
+theorem lazyRun_signingProgram_probeMessageBound (key : SecretKey)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (message : Message)
+    (hinputs : hashInputs (signWithView key message) ⊆ inputs) (state : State inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) (hbound : ProbeMessageBound state.memory)
+    (result : Option (Option Signature) × State inputs)
+    (hresult : lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+      (signingProgram inputs key.parameter key.root words selections message) state result ≠ 0) :
+    ProbeMessageBound result.2.memory := by
+  rw [lazyRun_signingProgram key inputs hencoding words publicReplies selections rows message state,
+    map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨raw, hraw, hresult⟩ := hresult
+  have hloop := (ResidualByteFrontend.hashInputs_publicSigningWork_subset_signWithView key state.memory.routing.known words selections message).trans hinputs
+  rw [ResidualByteFrontend.hashInputs_publicSigningWork] at hloop
+  obtain ⟨record, hrecord, hmemory⟩ := lazyRun_jointSigningProgram_memory_trace key.parameter inputs hencoding words publicReplies selections rows
+    state.memory.routing key.root message hloop state ha hcovered raw hraw
+  simp only [Function.comp_def, hrecord, Option.elim_some, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+  subst result
+  change ProbeMessageBound raw.2.memory
+  rw [hmemory]
+  exact applyBoundary_probeMessageBound state.memory hbound record.2
+
+omit parameter hencoding in
+theorem lazyRun_request_probeMessageBound (key : SecretKey)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (input : (OracleWorld + SigningSpec).Domain)
+    (hinputs : requestInputs key input ⊆ inputs) (state : State inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) (hbound : ProbeMessageBound state.memory)
+    (result : Option ((OracleWorld + SigningSpec).Range input) × State inputs)
+    (hresult : lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+      (adversaryImpl inputs key.parameter key.root words selections input) state result ≠ 0) : ProbeMessageBound result.2.memory := by
+  cases input with
+  | inl input =>
+      change lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+        (externalProgram inputs key.parameter words selections (liftM (OracleWorld.query input))) state result ≠ 0 at hresult
+      rw [lazyRun_externalProgram] at hresult
+      exact lazyByteRun_world_probeMessageBound key.parameter inputs hencoding words publicReplies selections rows
+        state.memory.routing input hinputs state ha hbound result hresult
+  | inr message =>
+      exact lazyRun_signingProgram_probeMessageBound inputs words publicReplies selections rows key hencoding message hinputs state
+        ha hcovered hbound result hresult
+
+variable (key : SecretKey) (adversary : Adversary) (encoding : ReferenceEncodingAuxiliary) (dummy : OtsReferenceWords)
+  (exposed : InitialPublicLabels (referenceFamilyWords encoding.selections dummy)) (high : CanonicalGraphHighHalves)
+  (q : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule) (stopped : Bool)
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProgram.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProgram.lean
new file mode 100644
index 000000000..c4f65242b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProgram.lean
@@ -0,0 +1,81 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.ResidualSigningProgram
+import SphincsSecurity.Proof.Residual.RetainedResidualExecution
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs
+set_option backward.isDefEq.respectTransparency false
+
+def currentRouting (inputs : Finset HashInput) : OracleComp (World inputs) Routing :=
+  liftM ((World inputs).query (.inl .routing))
+
+def recordSigning (inputs : Finset HashInput) (message : Message) (result : SigningRecord) : OracleComp (World inputs) Unit :=
+  liftM ((World inputs).query (.inl (.record message result)))
+
+noncomputable def externalProgram {Result : Type} (inputs : Finset HashInput) (parameter : PublicParameter)
+    (words : OtsReferenceWords) (selections : ReferenceFamily) (computation : OracleComp OracleWorld Result) :
+    OracleComp (World inputs) Result := do
+  let routing ← currentRouting inputs
+  simulateQ (embed inputs routing) (simulateQ (ResidualByteFrontend.checkedTranslate inputs
+    (PublicEncodingMatch.Match parameter (knownEncodingMessage routing.known) words selections)) computation)
+
+noncomputable def signingProgram (inputs : Finset HashInput) (parameter : PublicParameter) (root : Digest)
+    (words : OtsReferenceWords) (selections : ReferenceFamily) (message : Message) : OracleComp (World inputs) (Option Signature) := do
+  let routing ← currentRouting inputs
+  let result ← simulateQ (embed inputs routing)
+    (ResidualByteFrontend.jointSigningProgram inputs parameter root routing.known words selections message)
+  let _ ← recordSigning inputs message result
+  pure result.1.1
+
+noncomputable def adversaryImpl (inputs : Finset HashInput) (parameter : PublicParameter) (root : Digest)
+    (words : OtsReferenceWords) (selections : ReferenceFamily) :
+    QueryImpl (OracleWorld + SigningSpec) (OracleComp (World inputs))
+  | .inl input => externalProgram inputs parameter words selections (liftM (OracleWorld.query input))
+  | .inr message => signingProgram inputs parameter root words selections message
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+  (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem observedRun_routing_bind {Result : Type} (actual : Labels) (seed : inputs → HashOutput)
+    (next : Routing → OracleComp (World inputs) Result) (state : State inputs) :
+    observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+      (currentRouting inputs >>= next) state =
+      observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+        (next state.memory.routing) state := by
+  rw [currentRouting, observedRun, runWith_query_bind]
+  simp only [observedImpl, environment, OptionT.run_mk, StateT.run_mk, SPMF.lift_pure, pure_bind, Option.elim_some, observedRun]
+
+theorem observedRun_record_bind {Result : Type} (actual : Labels) (seed : inputs → HashOutput)
+    (message : Message) (result : SigningRecord) (next : Unit → OracleComp (World inputs) Result) (state : State inputs) :
+    observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+      (recordSigning inputs message result >>= next) state =
+      observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+        (next ()) { state with memory := state.memory.recordSigning message result } := by
+  rw [recordSigning, observedRun, runWith_query_bind]
+  simp only [observedImpl, environment, OptionT.run_mk, StateT.run_mk, SPMF.lift_pure, pure_bind, Option.elim_some, observedRun]
+
+theorem observedRun_signingProgram (actual : Labels) (seed : inputs → HashOutput)
+    (root : Digest) (message : Message) (state : State inputs) :
+    observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+      (signingProgram inputs parameter root words selections message) state =
+      (observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+        (simulateQ (embed inputs state.memory.routing)
+          (ResidualByteFrontend.jointSigningProgram inputs parameter root state.memory.routing.known words selections message)) state >>= fun result =>
+        result.1.elim (pure (none, result.2)) (fun record =>
+          pure (some record.1.1, { result.2 with memory := result.2.memory.recordSigning message record }))) := by
+  rw [signingProgram, observedRun_routing_bind, observedRun_bind]
+  apply congrArg (_ >>= ·)
+  funext result
+  rcases result with ⟨record, after⟩
+  cases record with
+  | none => rfl
+  | some record =>
+      rw [Option.elim_some, observedRun_record_bind]
+      exact runWith_pure _ _ _
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalIndex.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalIndex.lean
new file mode 100644
index 000000000..8511715be
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalIndex.lean
@@ -0,0 +1,140 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.OriginalProposalExecution
+import SphincsSecurity.Proof.Residual.RetainedResidualSigningLaw
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec ENNReal CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+  lazyRun environment signDigestLoop ResidualByteFrontend.jointSigningProgram
+set_option backward.isDefEq.respectTransparency false
+
+theorem completeSelectedIndex_fallback (view : Option FewTimeView) :
+    𝒟[completeSelectedIndex view] =
+      (fun fallback : Index => view.elim fallback Prod.fst) <$> (liftM (PMF.uniformOfFintype Index) : SPMF Index) := by
+  cases view with
+  | none =>
+      simp only [completeSelectedIndex, Option.elim_none, id_map']
+      apply SPMF.ext
+      intro index
+      change Pr[= index | ($ᵗ Index : ProbComp Index)] = _
+      rw [probOutput_uniformSample, SPMF.liftM_apply, PMF.uniformOfFintype_apply]
+  | some view =>
+      simp only [completeSelectedIndex, Option.elim_some, evalDist_pure, map_eq_bind_pure_comp, Function.comp_def]
+      exact (RetainedObservation.lift_bind_const _ _).symm
+
+noncomputable def completeRecordIndex {Result : Type} (law : SPMF Result) (view : Result → Option FewTimeView) :
+    SPMF (Result × Index) :=
+  law >>= fun result => (fun index => (result, index)) <$> 𝒟[completeSelectedIndex (view result)]
+
+theorem completeRecordIndex_record {Result : Type} (law : SPMF Result) (view : Result → Option FewTimeView) :
+    Prod.fst <$> completeRecordIndex law view = law := by
+  rw [completeRecordIndex, map_bind]
+  simp only [Functor.map_map]
+  calc
+    _ = law >>= pure := by
+      apply congrArg (law >>= ·)
+      funext result
+      rw [completeSelectedIndex_fallback, Functor.map_map, map_eq_bind_pure_comp]
+      exact RetainedObservation.lift_bind_const _ _
+    _ = _ := bind_pure law
+
+theorem completeRecordIndex_index {Result : Type} (law : SPMF Result) (view : Result → Option FewTimeView) :
+    Prod.snd <$> completeRecordIndex law view =
+      ((view <$> law) >>= fun selected => 𝒟[completeSelectedIndex selected]) := by
+  simp only [completeRecordIndex, map_bind, Functor.map_map, bind_map_left, id_map']
+
+theorem completeRecordIndex_fallback {Result : Type} (law : SPMF Result) (view : Result → Option FewTimeView) :
+    completeRecordIndex law view =
+      ((liftM (PMF.uniformOfFintype Index) : SPMF Index) >>= fun fallback =>
+        (fun result => (result, (view result).elim fallback Prod.fst)) <$> law) := by
+  simp only [completeRecordIndex, completeSelectedIndex_fallback, map_eq_bind_pure_comp, Function.comp_def,
+    bind_assoc, pure_bind]
+  exact RetainedObservation.bind_comm _ _ _
+
+private theorem lift_probComp_evalDist {Result : Type} (computation : ProbComp Result) :
+    (liftM (liftM computation : PMF Result) : SPMF Result) = 𝒟[computation] := by
+  apply SPMF.ext
+  intro result
+  rw [SPMF.liftM_apply, ← PMF.probOutput_eq_apply]
+  rfl
+
+theorem originalProposalRecord_index_loop (key : SecretKey) (message : Message) (cache : QueryCache HashSpec) :
+    (liftM ((originalProposalRecord key (.inr message) cache).map (fun record => record.index)) : SPMF Index) =
+      ((selectedLoopView? <$> 𝒟[(simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run cache]) >>=
+        fun selected => 𝒟[completeSelectedIndex selected]) := by
+  rw [originalProposalRecord_index, completedSigningRecord_index, lift_probComp_evalDist,
+    bind_map_left, ← evalDist_bind]
+  apply SPMF.ext
+  intro index
+  exact probOutput_tracedSigningIndex_eq_loop (signingBoundaryTrace key.parameter) key message cache index
+
+def nativeSigningView {inputs : Finset HashInput} (result : Option SigningRecord × State inputs) : Option FewTimeView :=
+  result.1.bind (fun record => record.1.2)
+
+variable (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+  (words : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+  (message : Message) (state : State inputs)
+
+theorem lazySigning_selectedView
+    (hinputs : hashInputs (signDigestLoop digestAttemptLimit key message) ⊆ inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) :
+    nativeSigningView <$> lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+      (simulateQ (embed inputs state.memory.routing)
+        (ResidualByteFrontend.jointSigningProgram inputs key.parameter key.root state.memory.routing.known words selections message)) state =
+      selectedLoopView? <$> 𝒟[(simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run state.memory.external.cache] := by
+  let observe : Option (Option Signature × Option FewTimeView) × QueryCache HashSpec → Option FewTimeView :=
+    fun result => result.1.bind Prod.snd
+  calc
+    _ = observe <$> (eraseSigningTrace <$> (cacheResult <$> lazyRun
+        (environment key.parameter inputs hencoding words publicReplies selections rows)
+        (simulateQ (embed inputs state.memory.routing)
+          (ResidualByteFrontend.jointSigningProgram inputs key.parameter key.root state.memory.routing.known words selections message)) state)) := by
+      simp only [Functor.map_map]
+      congr 1
+      funext result
+      rcases result with ⟨record, after⟩
+      cases record <;> rfl
+    _ = _ := by
+      rw [lazyRun_jointSigningProgram_digestLaw key.parameter inputs hencoding words publicReplies selections rows
+        state.memory.routing key rfl message hinputs state ha hcovered, map_bind]
+      calc
+        _ = UniformTableCompletion.complete state.candidates >>= fun _ =>
+            selectedLoopView? <$> 𝒟[(simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run state.memory.external.cache] := by
+          apply congrArg (UniformTableCompletion.complete state.candidates >>= ·)
+          funext actual
+          rw [evalDist_map, Functor.map_map, Functor.map_map]
+          congr 1
+          funext loop
+          exact (digestCompletionValue_preservesMessages key state.memory.routing.known words selections actual loop).1.1
+        _ = _ := by
+          rw [UniformTableCompletion.complete_of_nonempty state.candidates ha, RetainedObservation.lift_bind_const]
+
+noncomputable def completedNativeSigning : SPMF ((Option SigningRecord × State inputs) × Index) :=
+  completeRecordIndex
+    (lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+      (simulateQ (embed inputs state.memory.routing)
+        (ResidualByteFrontend.jointSigningProgram inputs key.parameter key.root state.memory.routing.known words selections message)) state)
+    nativeSigningView
+
+theorem completedNativeSigning_record :
+    Prod.fst <$> completedNativeSigning key inputs hencoding words publicReplies selections rows message state =
+      lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+        (simulateQ (embed inputs state.memory.routing)
+          (ResidualByteFrontend.jointSigningProgram inputs key.parameter key.root state.memory.routing.known words selections message)) state :=
+  completeRecordIndex_record _ _
+
+theorem completedNativeSigning_index
+    (hinputs : hashInputs (signDigestLoop digestAttemptLimit key message) ⊆ inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) :
+    Prod.snd <$> completedNativeSigning key inputs hencoding words publicReplies selections rows message state =
+      (liftM ((originalProposalRecord key (.inr message) state.memory.external.cache).map (fun record => record.index)) : SPMF Index) := by
+  rw [completedNativeSigning, completeRecordIndex_index,
+    lazySigning_selectedView key inputs hencoding words publicReplies selections rows message state hinputs ha hcovered,
+    originalProposalRecord_index_loop]
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalInvariant.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalInvariant.lean
new file mode 100644
index 000000000..67d407cec
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalInvariant.lean
@@ -0,0 +1,134 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.CertificateProposalInvariant
+import SphincsSecurity.Proof.Residual.RetainedResidualProposalStep
+import SphincsSecurity.Proof.Residual.RetainedResidualProposalSupport
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec ENNReal CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (SigningRecord)
+open FtsProbeSimulation (messageAnswers)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs sourceInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+  lazyRun environment signDigestLoop ResidualByteFrontend.jointSigningProgram
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def proposalStop (stopAfter : CertificateStopRule) : CertificateStopRule :=
+  fun input state length record => proposalPrefixStop input state length record || stopAfter input state length record
+
+theorem proposalStop_eq (stopAfter : CertificateStopRule) :
+    proposalStop stopAfter = fun input state length record =>
+      proposalPrefixStop input state length record || stopAfter input state length record := rfl
+
+def ProposalInvariant {inputs : Finset HashInput} (key : SecretKey) (total : Nat) (state : ProposalState inputs) : Prop :=
+  CertificateProposalInvariant key total (state.1, monitorView state.2)
+
+variable (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+  (words : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+  (budget total : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+theorem monitoredWorldResult_proposalInvariant (input : OracleWorld.Domain) (state : ProposalState inputs)
+    (hinputs : requestInputs key (.inl input) ⊆ inputs) (hvalid : MonitoredValid inputs state.2)
+    (hinv : ProposalInvariant key total state) (result : Option (OracleWorld.Range input) × State inputs)
+    (hresult : lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+      (externalProgram inputs key.parameter words selections (liftM (OracleWorld.query input))) state.2.1 result ≠ 0) :
+    ProposalInvariant key total (state.1,
+      (monitoredWorldResult key budget required (proposalStop stopAfter) input state.2 result).2) := by
+  rcases result with ⟨answer, after⟩
+  cases answer with
+  | none => intro hpost; cases hpost
+  | some answer =>
+      by_cases hactive : CertificateMonitorActive key budget (.inl input) (monitorView state.2)
+      · have hbefore := hinv hactive.1
+        have hstable := lazyWorld_observedViews key inputs hencoding words publicReplies selections rows input state.2.1
+          hinputs hvalid.1 hvalid.2 state.2.2.log hactive.2.1.1 (some answer, after) hresult
+        dsimp only at hstable
+        have hafter := certificateProposalInvariant_advance key budget total required stopAfter (.inl input)
+          (state.1, monitorView state.2) [] 0
+          (proposalOfWorldResult key.parameter input (answer, after.memory.external.cache)) hinv hactive rfl
+          (fun index => by
+            change (signingSlotsAtIndex (observedOptionalSigningViews (messageAnswers key.parameter after.memory.external.cache)
+              key.root (state.2.2.log ++ [])) index).card ≤ (state.1 ++ []).count index
+            rw [List.append_nil, List.append_nil, hstable]
+            exact hbefore.counts_le index)
+        rw [← proposalStop_eq] at hafter
+        simpa only [ProposalInvariant, monitorView, monitoredWorldResult, Option.elim_some,
+          originalProposalAdvance, proposalOfWorldResult, List.append_nil] using hafter
+      · intro hpost
+        change (certificateMonitorUpdate key budget required (proposalStop stopAfter) (.inl input)
+          (monitorView state.2) 0 (proposalOfWorldResult key.parameter input (answer, after.memory.external.cache))).stopped = false at hpost
+        simp only [certificateMonitorUpdate, if_neg hactive, Bool.true_eq_false] at hpost
+
+theorem completedSigning_proposalInvariant (message : Message) (state : ProposalState inputs)
+    (hinputs : requestInputs key (.inr message) ⊆ inputs) (hvalid : MonitoredValid inputs state.2)
+    (hinv : ProposalInvariant key total state)
+    (hactive : CertificateMonitorActive key budget (.inr message) (monitorView state.2))
+    (word : List Index) (result : (Option SigningRecord × State inputs) × Index)
+    (hresult : completedNativeSigning key inputs hencoding words publicReplies selections rows message state.2.1 result ≠ 0) :
+    ProposalInvariant key total (state.1 ++ (word ++ [result.2]),
+      (monitoredSigningResult key budget required (proposalStop stopAfter) message
+        (word.length + 1, result.2) state.2 result.1).2) := by
+  have hraw := map_nonzero _ Prod.fst result hresult
+  rw [completedNativeSigning_record] at hraw
+  have hin := digestInputs_of_request key inputs words selections message state.2.1.memory.routing.known hinputs
+  obtain ⟨record, hrecord⟩ := lazyRun_jointSigningProgram_some key.parameter inputs hencoding words publicReplies selections rows
+    state.2.1.memory.routing key.root message (by simpa only [publicDigestLoop_eq] using hin)
+    state.2.1 hvalid.1 hvalid.2 result.1 hraw
+  have heffective : record.1.2.elim result.2 Prod.fst = result.2 := by
+    have h := completeRecordIndex_effective _ nativeSigningView result hresult
+    simpa only [nativeSigningView, hrecord, Option.bind_some] using h
+  have hbefore := hinv hactive.1
+  have hafter := certificateProposalInvariant_advance key budget total required stopAfter (.inr message)
+    (state.1, monitorView state.2) (word ++ [result.2]) (word.length + 1)
+    (proposalOfSigningRecord message record result.1.2.memory.external.cache result.2) hinv hactive
+    (by simp only [List.length_append, List.length_singleton]) (fun index => by
+      have hc := completedNativeSigning_slots_le key inputs hencoding words publicReplies selections rows message state.2.1
+        hin hvalid.1 hvalid.2 state.2.2.log hactive.2.1.1 result hresult record hrecord index
+      calc
+        _ ≤ _ := hc
+        _ ≤ state.1.count index + if result.2 = index then 1 else 0 :=
+          Nat.add_le_add_right (hbefore.counts_le index) _
+        _ ≤ (state.1 ++ (word ++ [result.2])).count index := by
+          simp only [List.count_append, List.count_cons, List.count_nil, beq_iff_eq]
+          split_ifs <;> omega)
+  rw [← proposalStop_eq] at hafter
+  simpa only [ProposalInvariant, monitorView, monitoredSigningResult, hrecord, heffective,
+    originalProposalAdvance, proposalOfSigningRecord, Memory.recordSigning] using hafter
+
+theorem proposalStep_invariant (input : (OracleWorld + SigningSpec).Domain) (state : ProposalState inputs)
+    (hinputs : requestInputs key input ⊆ inputs) (hvalid : MonitoredValid inputs state.2)
+    (hinv : ProposalInvariant key total state)
+    (result : Option ((OracleWorld + SigningSpec).Range input) × ProposalState inputs)
+    (hresult : proposalStep key inputs hencoding words publicReplies selections rows budget required (proposalStop stopAfter) input state result ≠ 0) :
+    ProposalInvariant key total result.2 := by
+  cases input with
+  | inl input =>
+      rw [proposalStep] at hresult
+      obtain ⟨middle, hmiddle, rfl⟩ := map_nonzero_source _ _ _ hresult
+      rw [monitoredStep] at hmiddle
+      obtain ⟨raw, hraw, rfl⟩ := map_nonzero_source _ _ _ hmiddle
+      exact monitoredWorldResult_proposalInvariant key inputs hencoding words publicReplies selections rows budget total required stopAfter
+        input state hinputs hvalid hinv raw hraw
+  | inr message =>
+      rw [proposalStep] at hresult
+      split_ifs at hresult with hactive
+      · obtain ⟨source, hsource, rfl⟩ := map_nonzero_source _ _ _ hresult
+        have hrecord := map_nonzero _ Prod.snd source hsource
+        rw [attachRejectedWord_record] at hrecord
+        exact completedSigning_proposalInvariant key inputs hencoding words publicReplies selections rows budget total required stopAfter
+          message state hinputs hvalid hinv hactive source.1 source.2 hrecord
+      · obtain ⟨middle, hmiddle, rfl⟩ := map_nonzero_source _ _ _ hresult
+        rw [monitoredStep, RetainedObservation.bind_nonzero] at hmiddle
+        obtain ⟨annotation, _, hmiddle⟩ := hmiddle
+        obtain ⟨raw, _, rfl⟩ := map_nonzero_source _ _ _ hmiddle
+        rcases raw with ⟨answer, after⟩
+        cases answer with
+        | none => intro hpost; cases hpost
+        | some record =>
+            intro hpost
+            change (certificateMonitorUpdate key budget required (proposalStop stopAfter) (.inr message)
+              (monitorView state.2) annotation.1
+              (proposalOfSigningRecord message record after.memory.external.cache (record.1.2.elim annotation.2 Prod.fst))).stopped = false at hpost
+            simp only [certificateMonitorUpdate, if_neg hactive, Bool.true_eq_false] at hpost
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalPayment.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalPayment.lean
new file mode 100644
index 000000000..ec3f01fe1
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalPayment.lean
@@ -0,0 +1,170 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualProposalInvariant
+import SphincsSecurity.Proof.Residual.RetainedResidualProposalRun
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec ENNReal CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs sourceInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+variable (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+  (words : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+  (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+noncomputable def expectedProposalPayment
+    (charge : (OracleWorld + SigningSpec).Domain → ProposalState inputs → ENNReal)
+    {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result) : ProposalState inputs → ENNReal :=
+  OracleComp.construct (fun _ _ => 0) (fun input _ next state => charge input state +
+    ∑' result, Pr[= result | proposalStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+      result.1.elim 0 (fun answer => next answer result.2)) computation
+
+theorem expectedProposalPayment_query_bind
+    (charge : (OracleWorld + SigningSpec).Domain → ProposalState inputs → ENNReal)
+    {Result : Type} (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Result)
+    (state : ProposalState inputs) :
+    expectedProposalPayment key inputs hencoding words publicReplies selections rows budget required stopAfter charge
+      (liftM ((OracleWorld + SigningSpec).query input) >>= next) state = charge input state +
+        ∑' result, Pr[= result | proposalStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+          result.1.elim 0 (fun answer =>
+            expectedProposalPayment key inputs hencoding words publicReplies selections rows budget required stopAfter charge (next answer) result.2) := rfl
+
+theorem expected_proposalRun_accumulator (counter : ProposalState inputs → ENNReal)
+    (charge : (OracleWorld + SigningSpec).Domain → ProposalState inputs → ENNReal)
+    (hstep : ∀ input state, MonitoredValid inputs state.2 → requestInputs key input ⊆ inputs →
+      (∑' result, Pr[= result | proposalStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+        counter result.2) = counter state + charge input state)
+    {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : ProposalState inputs) (hvalid : MonitoredValid inputs state.2) (hinputs : sourceInputs key computation ⊆ inputs) :
+    (∑' result, Pr[= result | proposalRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state] *
+      counter result.2) = counter state +
+        expectedProposalPayment key inputs hencoding words publicReplies selections rows budget required stopAfter charge computation state := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [proposalRun_pure, tsum_probOutput_pure_mul, expectedProposalPayment, construct_pure, add_zero]
+  | query_bind input next ih =>
+      rw [proposalRun_query_bind, tsum_probOutput_bind_mul]
+      change _ = counter state + (charge input state +
+        ∑' result, Pr[= result | proposalStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+          result.1.elim 0 (fun answer =>
+            expectedProposalPayment key inputs hencoding words publicReplies selections rows budget required stopAfter charge (next answer) result.2))
+      calc
+        _ = ∑' result, Pr[= result | proposalStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+            (counter result.2 + result.1.elim 0 (fun answer =>
+              expectedProposalPayment key inputs hencoding words publicReplies selections rows budget required stopAfter charge (next answer) result.2)) := by
+          apply tsum_congr
+          intro result
+          by_cases hr : Pr[= result | proposalStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] = 0
+          · simp only [hr, zero_mul]
+          · rw [SPMF.probOutput_eq_apply] at hr
+            have hafter := proposalStep_valid key inputs hencoding words publicReplies selections rows budget required stopAfter input state hvalid result hr
+            apply congrArg (_ * ·)
+            rcases result with ⟨answer, after⟩
+            cases answer with
+            | none => simp only [Option.elim_none, tsum_probOutput_pure_mul, add_zero]
+            | some answer => exact ih answer after hafter ((sourceInputs_next_subset key input next answer).trans hinputs)
+        _ = _ := by
+          simp only [mul_add, ENNReal.tsum_add]
+          rw [hstep input state hvalid ((requestInputs_subset key input next).trans hinputs), add_assoc]
+
+theorem proposalStep_creation_counters (input : (OracleWorld + SigningSpec).Domain) (state : ProposalState inputs)
+    (hvalid : MonitoredValid inputs state.2) (hinputs : requestInputs key input ⊆ inputs)
+    (result : Option ((OracleWorld + SigningSpec).Range input) × ProposalState inputs)
+    (hresult : proposalStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state result ≠ 0) :
+    result.2.2.2.creationCost = state.2.2.creationCost + certificateMonitorCharge key budget required input (monitorView state.2) ∧
+      result.2.2.2.creationMass = state.2.2.creationMass + certificateMonitorMass key budget input (monitorView state.2) := by
+  have h := map_nonzero _ (Prod.map id Prod.snd) result hresult
+  rw [proposalStep_erasure] at h
+  exact monitoredStep_creation_counters key inputs hencoding words publicReplies selections rows budget required stopAfter
+    input state.2 hvalid hinputs _ h
+
+theorem expected_proposalStep_creationCost (input : (OracleWorld + SigningSpec).Domain) (state : ProposalState inputs)
+    (hvalid : MonitoredValid inputs state.2) (hinputs : requestInputs key input ⊆ inputs) :
+    (∑' result, Pr[= result | proposalStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+      result.2.2.2.creationCost) = state.2.2.creationCost + certificateMonitorCharge key budget required input (monitorView state.2) := by
+  have h := congrArg (fun law : SPMF (Option ((OracleWorld + SigningSpec).Range input) × MonitoredState inputs) =>
+    ∑' result, Pr[= result | law] * result.2.2.creationCost)
+    (proposalStep_erasure key inputs hencoding words publicReplies selections rows budget required stopAfter input state)
+  rw [tsum_probOutput_map_mul] at h
+  exact h.trans (expected_monitoredStep_creationCost key inputs hencoding words publicReplies selections rows budget required stopAfter
+    input state.2 hvalid hinputs)
+
+theorem expected_proposalStep_mass_terminalPotential (total : Nat) (payoff : List Index → ENNReal)
+    (input : (OracleWorld + SigningSpec).Domain) (state : ProposalState inputs)
+    (hvalid : MonitoredValid inputs state.2) (hinputs : requestInputs key input ⊆ inputs) :
+    (∑' result, Pr[= result | proposalStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+      (result.2.2.2.creationMass * terminalProposalPotential (PMF.uniformOfFintype Index) total payoff result.2.1)) =
+        state.2.2.creationMass * terminalProposalPotential (PMF.uniformOfFintype Index) total payoff state.1 +
+          certificateMonitorMass key budget input (monitorView state.2) *
+            terminalProposalPotential (PMF.uniformOfFintype Index) total payoff state.1 := by
+  let mass := state.2.2.creationMass + certificateMonitorMass key budget input (monitorView state.2)
+  calc
+    _ = ∑' result, Pr[= result | proposalStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+        (mass * terminalProposalPotential (PMF.uniformOfFintype Index) total payoff result.2.1) := by
+      apply tsum_congr
+      intro result
+      by_cases hr : Pr[= result | proposalStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] = 0
+      · simp only [hr, zero_mul]
+      · rw [SPMF.probOutput_eq_apply] at hr
+        rw [(proposalStep_creation_counters key inputs hencoding words publicReplies selections rows budget required stopAfter
+          input state hvalid hinputs result hr).2]
+    _ = mass * ∑' result, Pr[= result | proposalStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+        terminalProposalPotential (PMF.uniformOfFintype Index) total payoff result.2.1 := by
+      simp_rw [mul_left_comm _ mass]
+      exact ENNReal.tsum_mul_left
+    _ = _ := by
+      rw [expected_proposalStep_terminalPotential key inputs hencoding words publicReplies selections rows budget required stopAfter
+        input state hinputs hvalid total payoff]
+      exact add_mul _ _ _
+
+theorem expected_proposalRun_creationCost_le_mass_terminalPotential (total : Nat)
+    {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : ProposalState inputs) (hvalid : MonitoredValid inputs state.2) (hinputs : sourceInputs key computation ⊆ inputs)
+    (hbudget : budget ≤ 2 ^ 127) (hinv : ProposalInvariant key total state) :
+    (∑' result, Pr[= result | proposalRun key inputs hencoding words publicReplies selections rows budget required (proposalStop stopAfter) computation state] *
+      result.2.2.2.creationCost) ≤ state.2.2.creationCost +
+      ∑' result, Pr[= result | proposalRun key inputs hencoding words publicReplies selections rows budget required (proposalStop stopAfter) computation state] *
+        (result.2.2.2.creationMass * terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice required) result.2.1) := by
+  let first := fun input (state : ProposalState inputs) => certificateMonitorCharge key budget required input (monitorView state.2)
+  let second := fun input (state : ProposalState inputs) => certificateMonitorMass key budget input (monitorView state.2) *
+    terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice required) state.1
+  have hcharge : expectedProposalPayment key inputs hencoding words publicReplies selections rows budget required (proposalStop stopAfter) first computation state ≤
+      expectedProposalPayment key inputs hencoding words publicReplies selections rows budget required (proposalStop stopAfter) second computation state := by
+    induction computation using OracleComp.inductionOn generalizing state with
+    | pure value => exact le_rfl
+    | query_bind input next ih =>
+        rw [expectedProposalPayment_query_bind, expectedProposalPayment_query_bind]
+        apply add_le_add (certificateMonitorCharge_le_terminalPrice_of_invariant key budget total required input
+          (state.1, monitorView state.2) hbudget hinv)
+        apply ENNReal.tsum_le_tsum
+        intro result
+        by_cases hr : Pr[= result |
+            proposalStep key inputs hencoding words publicReplies selections rows budget required (proposalStop stopAfter) input state] = 0
+        · simp only [hr, zero_mul, le_refl]
+        · rw [SPMF.probOutput_eq_apply] at hr
+          have hafter := proposalStep_valid key inputs hencoding words publicReplies selections rows budget required (proposalStop stopAfter)
+            input state hvalid result hr
+          have hinv' := proposalStep_invariant key inputs hencoding words publicReplies selections rows budget total required stopAfter
+            input state ((requestInputs_subset key input next).trans hinputs) hvalid hinv result hr
+          apply mul_le_mul' le_rfl
+          rcases result with ⟨answer, after⟩
+          cases answer with
+          | none => exact le_rfl
+          | some answer => exact ih answer after hafter ((sourceInputs_next_subset key input next answer).trans hinputs) hinv'
+  have hcost := expected_proposalRun_accumulator key inputs hencoding words publicReplies selections rows budget required (proposalStop stopAfter)
+    (fun state => state.2.2.creationCost) first
+    (expected_proposalStep_creationCost key inputs hencoding words publicReplies selections rows budget required (proposalStop stopAfter))
+    computation state hvalid hinputs
+  have hmass := expected_proposalRun_accumulator key inputs hencoding words publicReplies selections rows budget required (proposalStop stopAfter)
+    (fun state => state.2.2.creationMass * terminalProposalPotential (PMF.uniformOfFintype Index) total (terminalCertificatePrice required) state.1) second
+    (expected_proposalStep_mass_terminalPotential key inputs hencoding words publicReplies selections rows budget required (proposalStop stopAfter)
+      total (terminalCertificatePrice required)) computation state hvalid hinputs
+  calc
+    _ = state.2.2.creationCost + expectedProposalPayment key inputs hencoding words publicReplies selections rows budget required (proposalStop stopAfter)
+        first computation state := hcost
+    _ ≤ state.2.2.creationCost + expectedProposalPayment key inputs hencoding words publicReplies selections rows budget required (proposalStop stopAfter)
+        second computation state := add_le_add le_rfl hcharge
+    _ ≤ _ := by rw [hmass]; exact add_le_add le_rfl le_add_self
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalRun.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalRun.lean
new file mode 100644
index 000000000..6498ba703
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalRun.lean
@@ -0,0 +1,97 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualProposalStep
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec ENNReal CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs sourceInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+variable (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+  (words : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+  (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+noncomputable def proposalImpl : QueryImpl (OracleWorld + SigningSpec) (OptionT (StateT (ProposalState inputs) SPMF)) :=
+  fun input => OptionT.mk (StateT.mk (proposalStep key inputs hencoding words publicReplies selections rows budget required stopAfter input))
+
+noncomputable def proposalRun {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : ProposalState inputs) : SPMF (Option Result × ProposalState inputs) :=
+  (simulateQ (proposalImpl key inputs hencoding words publicReplies selections rows budget required stopAfter) computation).run.run state
+
+theorem proposalRun_pure {Result : Type} (value : Result) (state : ProposalState inputs) :
+    proposalRun key inputs hencoding words publicReplies selections rows budget required stopAfter (pure value) state =
+      pure (some value, state) := by
+  simp only [proposalRun, simulateQ_pure, OptionT.run_pure, StateT.run_pure]
+
+theorem proposalRun_query_bind {Result : Type} (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Result)
+    (state : ProposalState inputs) :
+    proposalRun key inputs hencoding words publicReplies selections rows budget required stopAfter
+      (liftM ((OracleWorld + SigningSpec).query input) >>= next) state =
+      (proposalStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state >>= fun result =>
+        result.1.elim (pure (none, result.2)) fun answer =>
+          proposalRun key inputs hencoding words publicReplies selections rows budget required stopAfter (next answer) result.2) := by
+  simp only [proposalRun, simulateQ_bind, simulateQ_spec_query, OptionT.run_bind, Option.elimM, StateT.run_bind,
+    proposalImpl, OptionT.run_mk, StateT.run_mk]
+  apply congrArg (_ >>= ·)
+  funext result
+  rcases result with ⟨answer, after⟩
+  cases answer <;> rfl
+
+theorem proposalRun_erasure {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : ProposalState inputs) :
+    Prod.map id Prod.snd <$>
+        proposalRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state =
+      monitoredRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state.2 := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [proposalRun_pure, monitoredRun_pure, map_pure]; rfl
+  | query_bind input next ih =>
+      rw [proposalRun_query_bind, map_bind, monitoredRun_query_bind,
+        ← proposalStep_erasure key inputs hencoding words publicReplies selections rows budget required stopAfter input state,
+        bind_map_left]
+      apply RetainedObservation.bind_congr
+      rintro ⟨answer, after⟩ _
+      cases answer with
+      | none => simp only [Option.elim_none, map_pure]; rfl
+      | some answer => exact ih answer after
+
+theorem proposalRun_complete {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : ProposalState inputs) (hvalid : MonitoredValid inputs state.2)
+    (hinputs : sourceInputs key computation ⊆ inputs) (total : Nat) :
+    (proposalRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state >>= fun result =>
+      (liftM (completeProposalWord (PMF.uniformOfFintype Index) total result.2.1) : SPMF (List Index))) =
+      (liftM (completeProposalWord (PMF.uniformOfFintype Index) total state.1) : SPMF (List Index)) := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => rw [proposalRun_pure, pure_bind]
+  | query_bind input next ih =>
+      rw [proposalRun_query_bind, bind_assoc]
+      calc
+        _ = proposalStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state >>= fun result =>
+            (liftM (completeProposalWord (PMF.uniformOfFintype Index) total result.2.1) : SPMF (List Index)) := by
+          apply RetainedObservation.bind_congr
+          intro result hresult
+          have hafter := proposalStep_valid key inputs hencoding words publicReplies selections rows budget required stopAfter
+            input state hvalid result hresult
+          rcases result with ⟨answer, after⟩
+          cases answer with
+          | none => rw [Option.elim_none, pure_bind]
+          | some answer =>
+              exact ih answer after hafter ((sourceInputs_next_subset key input next answer).trans hinputs)
+        _ = _ := proposalStep_complete key inputs hencoding words publicReplies selections rows budget required stopAfter
+          input state ((requestInputs_subset key input next).trans hinputs) hvalid total
+
+theorem expected_proposalRun_terminalPotential {Result : Type}
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) (state : ProposalState inputs)
+    (hvalid : MonitoredValid inputs state.2) (hinputs : sourceInputs key computation ⊆ inputs)
+    (total : Nat) (payoff : List Index → ENNReal) :
+    (∑' result, Pr[= result |
+        proposalRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state] *
+      terminalProposalPotential (PMF.uniformOfFintype Index) total payoff result.2.1) =
+        terminalProposalPotential (PMF.uniformOfFintype Index) total payoff state.1 := by
+  have h := congrArg (fun law : SPMF (List Index) => ∑' word, Pr[= word | law] * payoff word)
+    (proposalRun_complete key inputs hencoding words publicReplies selections rows budget required stopAfter computation state hvalid hinputs total)
+  rw [tsum_probOutput_bind_mul] at h
+  simpa only [terminalProposalPotential, SPMF.probOutput_liftM] using h
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalStep.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalStep.lean
new file mode 100644
index 000000000..3e78860c6
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalStep.lean
@@ -0,0 +1,141 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.OriginalTerminalProposal
+import SphincsSecurity.Proof.Residual.RetainedResidualMonitoredPayment
+import SphincsSecurity.Proof.Residual.RetainedResidualProposalIndex
+import SphincsSecurity.Proof.Residual.RetainedResidualProposalWord
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec ENNReal CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs sourceInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+  lazyRun environment signDigestLoop ResidualByteFrontend.jointSigningProgram
+set_option backward.isDefEq.respectTransparency false
+
+abbrev ProposalState (inputs : Finset HashInput) := List Index × MonitoredState inputs
+
+theorem monitoredSigningResult_completed {inputs : Finset HashInput} (key : SecretKey) (budget : Nat)
+    (required : Finset FtsTree) (stopAfter : CertificateStopRule) (message : Message) (length : Nat)
+    (fallback : Index) (before : MonitoredState inputs) (result : Option SigningRecord × State inputs) :
+    monitoredSigningResult key budget required stopAfter message
+        (length, (nativeSigningView result).elim fallback Prod.fst) before result =
+      monitoredSigningResult key budget required stopAfter message (length, fallback) before result := by
+  rcases result with ⟨record, after⟩
+  cases record with
+  | none => rfl
+  | some record =>
+      rcases record with ⟨⟨signature, view⟩, trace⟩
+      cases view <;> rfl
+
+variable (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+  (words : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+  (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+theorem completedNativeSigning_monitored (message : Message) (length : Nat) (state : MonitoredState inputs) :
+    (fun result => monitoredSigningResult key budget required stopAfter message (length, result.2) state result.1) <$>
+        completedNativeSigning key inputs hencoding words publicReplies selections rows message state.1 =
+      ((liftM (PMF.uniformOfFintype Index) : SPMF Index) >>= fun fallback =>
+        monitoredSigningResult key budget required stopAfter message (length, fallback) state <$>
+          lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+            (simulateQ (embed inputs state.1.memory.routing)
+              (ResidualByteFrontend.jointSigningProgram inputs key.parameter key.root state.1.memory.routing.known words selections message)) state.1) := by
+  rw [completedNativeSigning, completeRecordIndex_fallback, map_bind]
+  simp only [Functor.map_map, monitoredSigningResult_completed]
+
+noncomputable def proposalStep :
+    (input : (OracleWorld + SigningSpec).Domain) → ProposalState inputs →
+      SPMF (Option ((OracleWorld + SigningSpec).Range input) × ProposalState inputs)
+  | .inl input, state =>
+      (fun result => (result.1, state.1, result.2)) <$>
+        monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter (.inl input) state.2
+  | .inr message, state =>
+      if CertificateMonitorActive key budget (.inr message) (monitorView state.2) then
+        (fun result =>
+          let after := monitoredSigningResult key budget required stopAfter message
+            (result.1.length + 1, result.2.2) state.2 result.2.1
+          (after.1, state.1 ++ (result.1 ++ [result.2.2]), after.2)) <$>
+          attachRejectedWord
+            (completedNativeSigning key inputs hencoding words publicReplies selections rows message state.2.1)
+            (originalRejectedProposal key (fun current => current.2.spent) (.inr message) (monitorView state.2))
+      else
+        (fun result => (result.1, state.1, result.2)) <$>
+          monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter (.inr message) state.2
+
+theorem proposalStep_erasure (input : (OracleWorld + SigningSpec).Domain) (state : ProposalState inputs) :
+    Prod.map id Prod.snd <$>
+        proposalStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state =
+      monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state.2 := by
+  cases input with
+  | inl input =>
+      rw [proposalStep, Functor.map_map]
+      exact id_map' _
+  | inr message =>
+      rw [proposalStep]
+      split_ifs with hactive
+      · rw [Functor.map_map]
+        calc
+          _ = (fun result => monitoredSigningResult key budget required stopAfter message
+                (result.1, result.2.2) state.2 result.2.1) <$>
+              ((fun result => (result.1.length + 1, result.2)) <$>
+                attachRejectedWord
+                  (completedNativeSigning key inputs hencoding words publicReplies selections rows message state.2.1)
+                  (originalRejectedProposal key (fun current => current.2.spent) (.inr message) (monitorView state.2))) := by
+            rw [Functor.map_map]
+            rfl
+          _ = _ := by
+            rw [attachRejectedWord_length, map_bind, monitoredStep, signingAnnotation, if_pos hactive, pmfLift_bind]
+            simp only [Functor.map_map, pmfLift_map, bind_assoc, bind_map_left]
+            simp_rw [completedNativeSigning_monitored]
+      · rw [Functor.map_map]
+        exact id_map' _
+
+theorem proposalStep_valid (input : (OracleWorld + SigningSpec).Domain) (state : ProposalState inputs)
+    (hvalid : MonitoredValid inputs state.2)
+    (result : Option ((OracleWorld + SigningSpec).Range input) × ProposalState inputs)
+    (hresult : proposalStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state result ≠ 0) :
+    MonitoredValid inputs result.2.2 := by
+  have h := map_nonzero _ (Prod.map id Prod.snd) result hresult
+  rw [proposalStep_erasure] at h
+  exact monitoredStep_valid key inputs hencoding words publicReplies selections rows budget required stopAfter
+    input state.2 hvalid _ h
+
+theorem proposalStep_complete (input : (OracleWorld + SigningSpec).Domain) (state : ProposalState inputs)
+    (hinputs : requestInputs key input ⊆ inputs) (hvalid : MonitoredValid inputs state.2) (total : Nat) :
+    (proposalStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state >>= fun result =>
+      (liftM (completeProposalWord (PMF.uniformOfFintype Index) total result.2.1) : SPMF (List Index))) =
+      (liftM (completeProposalWord (PMF.uniformOfFintype Index) total state.1) : SPMF (List Index)) := by
+  cases input with
+  | inl input =>
+      rw [proposalStep, bind_map_left]
+      exact monitoredStep_bind_const key inputs hencoding words publicReplies selections rows budget required stopAfter
+        (.inl input) state.2 hvalid.1 (liftM (completeProposalWord (PMF.uniformOfFintype Index) total state.1))
+  | inr message =>
+      rw [proposalStep]
+      split_ifs with hactive
+      · rw [bind_map_left]
+        have hbound : ProposalCacheBound key (monitorView state.2).1 (monitorView state.2).2.spent := hactive.2.1.2.1
+        rw [originalRejectedProposal, dif_pos hbound]
+        exact attachRejectedWord_complete _ Prod.snd
+          (originalProposalRecord key (.inr message) (monitorView state.2).1) (fun record => record.index)
+          (completedNativeSigning_index key inputs hencoding words publicReplies selections rows message state.2.1
+            (digestInputs_of_request key inputs words selections message state.2.1.memory.routing.known hinputs)
+            hvalid.1 hvalid.2)
+          (originalProposalRecord_cap key message (monitorView state.2).1 (monitorView state.2).2.spent hbound) total state.1
+      · rw [bind_map_left]
+        exact monitoredStep_bind_const key inputs hencoding words publicReplies selections rows budget required stopAfter
+          (.inr message) state.2 hvalid.1 (liftM (completeProposalWord (PMF.uniformOfFintype Index) total state.1))
+
+theorem expected_proposalStep_terminalPotential (input : (OracleWorld + SigningSpec).Domain)
+    (state : ProposalState inputs) (hinputs : requestInputs key input ⊆ inputs)
+    (hvalid : MonitoredValid inputs state.2) (total : Nat) (payoff : List Index → ENNReal) :
+    (∑' result, Pr[= result |
+        proposalStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+      terminalProposalPotential (PMF.uniformOfFintype Index) total payoff result.2.1) =
+        terminalProposalPotential (PMF.uniformOfFintype Index) total payoff state.1 := by
+  have h := congrArg (fun law : SPMF (List Index) => ∑' word, Pr[= word | law] * payoff word)
+    (proposalStep_complete key inputs hencoding words publicReplies selections rows budget required stopAfter input state hinputs hvalid total)
+  rw [tsum_probOutput_bind_mul] at h
+  simpa only [terminalProposalPotential, SPMF.probOutput_liftM] using h
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalSupport.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalSupport.lean
new file mode 100644
index 000000000..ea8408c54
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalSupport.lean
@@ -0,0 +1,159 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualProposalIndex
+import SphincsSecurity.Proof.Residual.RetainedResidualWorldKernel
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec ENNReal CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (SigningRecord)
+open FtsProbeSimulation (messageAnswers MessageHashInput)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+  lazyRun environment signDigestLoop ResidualByteFrontend.jointSigningProgram
+set_option backward.isDefEq.respectTransparency false
+
+theorem map_nonzero_source {A B : Type} (law : SPMF A) (f : A → B) (result : B)
+    (hresult : (f <$> law) result ≠ 0) : ∃ source, law source ≠ 0 ∧ result = f source := by
+  rw [map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨source, hsource, hresult⟩ := hresult
+  exact ⟨source, hsource, by simpa only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] using hresult⟩
+
+theorem completeRecordIndex_selected {Result : Type} (law : SPMF Result) (view : Result → Option FewTimeView)
+    (result : Result × Index) (hresult : completeRecordIndex law view result ≠ 0)
+    (selected : FewTimeView) (hselected : view result.1 = some selected) : result.2 = selected.1 := by
+  rw [completeRecordIndex_fallback, RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨fallback, _, hresult⟩ := hresult
+  obtain ⟨source, _, rfl⟩ := map_nonzero_source _ _ _ hresult
+  simp only [hselected, Option.elim_some]
+
+theorem completeRecordIndex_effective {Result : Type} (law : SPMF Result) (view : Result → Option FewTimeView)
+    (result : Result × Index) (hresult : completeRecordIndex law view result ≠ 0) :
+    (view result.1).elim result.2 Prod.fst = result.2 := by
+  cases hview : view result.1 with
+  | none => rfl
+  | some selected =>
+      exact (completeRecordIndex_selected law view result hresult selected hview).symm
+
+variable (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+  (words : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem lazySigning_digestRecord (message : Message) (state : State inputs)
+    (hinputs : hashInputs (signDigestLoop digestAttemptLimit key message) ⊆ inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (result : Option SigningRecord × State inputs)
+    (hresult : lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+      (simulateQ (embed inputs state.memory.routing)
+        (ResidualByteFrontend.jointSigningProgram inputs key.parameter key.root state.memory.routing.known words selections message)) state result ≠ 0) :
+    ∃ record loop, result.1 = some record ∧
+      loop ∈ support ((simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run state.memory.external.cache) ∧
+      result.2.memory.external.cache = loop.2 ∧
+      DigestCompletionPreservesMessages key loop (record.1, result.2.memory.external.cache) := by
+  obtain ⟨record, hrecord⟩ := lazyRun_jointSigningProgram_some key.parameter inputs hencoding words publicReplies selections rows
+    state.memory.routing key.root message (by simpa only [publicDigestLoop_eq] using hinputs) state ha hcovered result hresult
+  have h := map_nonzero _ eraseSigningTrace (cacheResult result) (map_nonzero _ cacheResult result hresult)
+  rw [lazyRun_jointSigningProgram_digestLaw key.parameter inputs hencoding words publicReplies selections rows
+    state.memory.routing key rfl message hinputs state ha hcovered, RetainedObservation.bind_nonzero] at h
+  obtain ⟨actual, _, h⟩ := h
+  rw [evalDist_map, Functor.map_map] at h
+  obtain ⟨loop, hloop, heq⟩ := map_nonzero_source _ _ _ h
+  have hvalue : (record.1, result.2.memory.external.cache) = digestCompletionValue state.memory.routing.known words selections actual loop := by
+    have hfst := congrArg Prod.fst heq
+    have hsnd := congrArg Prod.snd heq
+    simp only [eraseSigningTrace, cacheResult, hrecord, Option.map_some, Prod.map_fst, Prod.map_snd, id_eq] at hfst hsnd
+    exact Prod.ext (Option.some.inj hfst) hsnd
+  have hcompletion := digestCompletionValue_preservesMessages key state.memory.routing.known words selections actual loop
+  rw [← hvalue] at hcompletion
+  exact ⟨record, loop, hrecord, (mem_support_iff_evalDist_apply_ne_zero _ _).mpr hloop,
+    congrArg Prod.snd hvalue, hcompletion⟩
+
+theorem completedNativeSigning_observed_index (message : Message) (state : State inputs)
+    (hinputs : hashInputs (signDigestLoop digestAttemptLimit key message) ⊆ inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (result : (Option SigningRecord × State inputs) × Index)
+    (hresult : completedNativeSigning key inputs hencoding words publicReplies selections rows message state result ≠ 0)
+    (record : SigningRecord) (hrecord : result.1.1 = some record) (view : FewTimeView)
+    (hview : observedSigningView? (messageAnswers key.parameter result.1.2.memory.external.cache) key.root
+      ⟨message, record.1.1⟩ = some view) : result.2 = view.1 := by
+  have hraw := map_nonzero _ Prod.fst result hresult
+  rw [completedNativeSigning_record] at hraw
+  obtain ⟨actualRecord, loop, hr, hloop, _, hcompletion⟩ := lazySigning_digestRecord key inputs hencoding words publicReplies selections rows
+    message state hinputs ha hcovered result.1 hraw
+  have heq : actualRecord = record := Option.some.inj (hr.symm.trans hrecord)
+  subst actualRecord
+  cases hs : record.1.1 with
+  | none => simp [observedSigningView?, hs] at hview
+  | some signature =>
+      obtain ⟨output, houtput, _, hselected⟩ := digestCompletion_successful_cached_output key message state.memory.external.cache
+        loop hloop (record.1, result.1.2.memory.external.cache) hcompletion signature hs
+      dsimp only at houtput hselected
+      have hv : hashOutputFewTimeView output = view := by
+        simpa [observedSigningView?, hs, messageAnswers, houtput] using hview
+      have hselected' : nativeSigningView result.1 = some (hashOutputFewTimeView output) := by
+        simp only [nativeSigningView, hrecord, Option.bind_some]
+        exact hselected
+      exact (completeRecordIndex_selected _ nativeSigningView result hresult _ hselected').trans (congrArg Prod.fst hv)
+
+theorem completedNativeSigning_slots_le (message : Message) (state : State inputs)
+    (hinputs : hashInputs (signDigestLoop digestAttemptLimit key message) ⊆ inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (log : QueryLog SigningSpec) (hsigned : SigningDigestsCached key.parameter state.memory.external.cache key.root log)
+    (result : (Option SigningRecord × State inputs) × Index)
+    (hresult : completedNativeSigning key inputs hencoding words publicReplies selections rows message state result ≠ 0)
+    (record : SigningRecord) (hrecord : result.1.1 = some record) (index : Index) :
+    (signingSlotsAtIndex (observedOptionalSigningViews (messageAnswers key.parameter result.1.2.memory.external.cache)
+      key.root (log ++ [⟨message, record.1.1⟩])) index).card ≤
+        (signingSlotsAtIndex (observedOptionalSigningViews (messageAnswers key.parameter state.memory.external.cache)
+          key.root log) index).card + if result.2 = index then 1 else 0 := by
+  have hraw := map_nonzero _ Prod.fst result hresult
+  rw [completedNativeSigning_record] at hraw
+  obtain ⟨_, loop, _, hloop, hcache, _⟩ := lazySigning_digestRecord key inputs hencoding words publicReplies selections rows
+    message state hinputs ha hcovered result.1 hraw
+  have hle := simulateQ_romImpl_cache_le _ _ _ hloop
+  rw [← hcache] at hle
+  have hstable := observedOptionalSigningViews_cache_stable key.parameter key.root _ _ log hle hsigned
+  unfold observedOptionalSigningViews
+  rw [signingSlotsAtIndex_log_append_card]
+  have heq := congrArg (fun views => (signingSlotsAtIndex views index).card) hstable
+  apply Nat.add_le_add heq.le
+  split_ifs with hobserved hindex hindex
+  · exact le_rfl
+  · obtain ⟨view, hview, hsource⟩ := hobserved
+    exact False.elim (hindex ((completedNativeSigning_observed_index key inputs hencoding words publicReplies selections rows
+      message state hinputs ha hcovered result hresult record hrecord view hview).trans hsource))
+  · exact Nat.zero_le _
+  · exact le_rfl
+
+theorem lazyWorld_observedViews (input : OracleWorld.Domain) (state : State inputs)
+    (hinputs : hashInputs (liftM (OracleWorld.query input)) ⊆ inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (log : QueryLog SigningSpec) (hsigned : SigningDigestsCached key.parameter state.memory.external.cache key.root log)
+    (result : Option (OracleWorld.Range input) × State inputs)
+    (hresult : lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+      (externalProgram inputs key.parameter words selections (liftM (OracleWorld.query input))) state result ≠ 0) :
+    observedOptionalSigningViews (messageAnswers key.parameter result.2.memory.external.cache) key.root log =
+      observedOptionalSigningViews (messageAnswers key.parameter state.memory.external.cache) key.root log := by
+  rw [lazyRun_externalProgram] at hresult
+  by_cases hmessage : ∀ hash, input = .inr hash → MessageHashInput key.parameter hash
+  · have h := map_nonzero _ cacheResult result hresult
+    rw [lazyByteRun_world_message_rom key.parameter inputs hencoding words publicReplies selections rows
+      state.memory.routing input hinputs hmessage state hcovered] at h
+    obtain ⟨source, hsource, heq⟩ := map_nonzero_source _ _ _ h
+    have hcache : result.2.memory.external.cache = source.2 := congrArg Prod.snd heq
+    rw [hcache]
+    apply observedOptionalSigningViews_cache_stable _ _ _ _ log _ hsigned
+    apply simulateQ_romImpl_cache_le (liftM (OracleWorld.query input)) state.memory.external.cache source
+    simpa only [simulateQ_spec_query] using (mem_support_iff_evalDist_apply_ne_zero _ _).mpr hsource
+  · cases input with
+    | inl sample => exact False.elim (hmessage (by intro hash h; cases h))
+    | inr input =>
+        have hm : ¬MessageHashInput key.parameter input := fun h => hmessage (by intro hash heq; cases heq; exact h)
+        have hin : input ∈ inputs := hinputs (by
+          simpa only [bind_pure] using mem_hashInputs_hash_bind input pure)
+        rw [lazyByteRun_hash_nonmessage key.parameter inputs hencoding words publicReplies selections rows
+          state.memory.routing input hin state ha hcovered hm result hresult]
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalTail.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalTail.lean
new file mode 100644
index 000000000..b9bb90d8a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalTail.lean
@@ -0,0 +1,126 @@
+import SphincsSecurity.Proof.Residual.RetainedResidualProposalTailStep
+import SphincsSecurity.Proof.Residual.RetainedResidualExceptionGame
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs sourceInputs
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def prefixHistoryWeight {inputs : Finset HashInput} (state : ExceptionHistoryState inputs) : ENNReal :=
+  if state.2.2 then 1 else proposalPrefixWeight state.1.2.proposals state.1.2.log.length
+
+section Kernel
+
+variable (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+  (words : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+  (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+theorem expected_exceptionHistoryStep_prefixWeight_le (input : (OracleWorld + SigningSpec).Domain) (state : ExceptionHistoryState inputs)
+    (hvalid : MonitoredValid inputs state.1) (hinputs : requestInputs key input ⊆ inputs)
+    (hcap : state.1.2.log.length ≤ signatureLimit) :
+    (∑' result, Pr[= result | exceptionHistoryStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+      prefixHistoryWeight result.2) ≤ prefixHistoryWeight state := by
+  rw [exceptionHistoryStep, tsum_probOutput_map_mul]
+  cases hflag : state.2.2 with
+  | true =>
+      simp only [prefixHistoryWeight, exceptionHistoryUpdate, hflag, Bool.true_or, ite_true, mul_one]
+      exact tsum_probOutput_le_one
+  | false =>
+      conv_rhs => simp only [prefixHistoryWeight, hflag, Bool.false_eq_true, if_false]
+      apply le_trans ?_ (expected_monitoredStep_prefixWeight_le key inputs hencoding words publicReplies selections rows budget required stopAfter
+        input state.1 hvalid hinputs)
+      apply ENNReal.tsum_le_tsum
+      intro result
+      by_cases hr : Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state.1] = 0
+      · simp only [hr, zero_mul, le_refl]
+      · rw [SPMF.probOutput_eq_apply] at hr
+        apply mul_le_mul' le_rfl
+        have hcap' := monitoredStep_log_cap key inputs hencoding words publicReplies selections rows budget required stopAfter input state.1 hcap result hr
+        simp only [prefixHistoryWeight, exceptionHistoryUpdate, hflag, Bool.false_or, decide_eq_true_eq]
+        split
+        · exact proposalPrefixWeight_bad _ _ hcap' (by assumption)
+        · exact le_rfl
+
+theorem expected_exceptionHistoryRun_prefixWeight_le {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : ExceptionHistoryState inputs) (hvalid : MonitoredValid inputs state.1)
+    (hinputs : sourceInputs key computation ⊆ inputs) (hcap : state.1.2.log.length ≤ signatureLimit) :
+    (∑' result, Pr[= result | exceptionHistoryRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state] *
+      prefixHistoryWeight result.2) ≤ prefixHistoryWeight state := by
+  induction computation using OracleComp.inductionOn generalizing state with
+  | pure value => simp only [exceptionHistoryRun_pure, tsum_probOutput_pure_mul, le_refl]
+  | query_bind input next ih =>
+      rw [exceptionHistoryRun_query_bind, tsum_probOutput_bind_mul]
+      apply le_trans ?_ (expected_exceptionHistoryStep_prefixWeight_le key inputs hencoding words publicReplies selections rows budget required stopAfter
+        input state hvalid ((requestInputs_subset key input next).trans hinputs) hcap)
+      apply ENNReal.tsum_le_tsum
+      intro result
+      by_cases hr : Pr[= result | exceptionHistoryStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] = 0
+      · simp only [hr, zero_mul, le_refl]
+      · rw [SPMF.probOutput_eq_apply] at hr
+        have hn := (exceptionHistoryStep_support key inputs hencoding words publicReplies selections rows budget required stopAfter input state result hr).1
+        have hv := monitoredStep_valid key inputs hencoding words publicReplies selections rows budget required stopAfter input state.1 hvalid _ hn
+        have hc := monitoredStep_log_cap key inputs hencoding words publicReplies selections rows budget required stopAfter input state.1 hcap _ hn
+        apply mul_le_mul' le_rfl
+        rcases result with ⟨answer, after⟩
+        cases answer with
+        | none => simp only [Option.elim_none, tsum_probOutput_pure_mul, le_refl]
+        | some answer => exact ih answer after hv ((sourceInputs_next_subset key input next answer).trans hinputs) hc
+
+theorem exceptionHistoryRun_prefix_le {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : ExceptionHistoryState inputs) (hvalid : MonitoredValid inputs state.1)
+    (hinputs : sourceInputs key computation ⊆ inputs) (hcap : state.1.2.log.length ≤ signatureLimit) :
+    Pr[fun result => result.2.2.2 = true |
+      exceptionHistoryRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state] ≤
+      prefixHistoryWeight state := by
+  apply le_trans ?_ (expected_exceptionHistoryRun_prefixWeight_le key inputs hencoding words publicReplies selections rows budget required stopAfter
+    computation state hvalid hinputs hcap)
+  apply probEvent_le_tsum_probOutput_mul_cost_of_mem_support
+  intro result _ hflag
+  simp only [prefixHistoryWeight, hflag, ite_true, le_refl]
+
+end Kernel
+
+attribute [local irreducible] gameInputs
+
+theorem initialExceptionHistorySource_prefix_le (key : SecretKey) (adversary : Adversary)
+    (encoding : ReferenceEncodingAuxiliary) (dummy : OtsReferenceWords)
+    (exposed : InitialPublicLabels (referenceFamilyWords encoding.selections dummy)) (high : CanonicalGraphHighHalves) (budget : Nat) :
+    Pr[fun result => result.2.2.2 = true | initialExceptionHistorySource key adversary encoding dummy exposed high budget] ≤ (2 ^ 700 : ENNReal)⁻¹ := by
+  apply le_trans (exceptionHistoryRun_prefix_le key (gameInputs adversary)
+    (canonicalEncodingInputs_subset_retainedGameInputs adversary key.parameter)
+    (referenceFamilyWords encoding.selections dummy)
+    (coordinateGraphLabels (initialKnown (referenceFamilyWords encoding.selections dummy) exposed) high)
+    encoding.selections encoding.rows budget Finset.univ (proposalStop (fun _ _ _ _ => false)) _ _
+    ⟨initialAllowed_nonempty _ exposed, initialState_rowsCovered _ _ exposed⟩
+    (sourceInputs_unlogged_subset_gameInputs adversary key) (Nat.zero_le _))
+  exact proposalPrefixWeight_initial_le
+
+theorem exceptionHistorySourceGame_prefix_le (dummy : OtsReferenceWords) (adversary : Adversary) (budget : Nat) :
+    Pr[fun result => result.2.2.2 = true | exceptionHistorySourceGame dummy adversary budget] ≤ (2 ^ 700 : ENNReal)⁻¹ := by
+  unfold exceptionHistorySourceGame
+  apply probEvent_bind_le_of_forall_le
+  intro parameter _
+  apply probEvent_bind_le_of_forall_le
+  intro encoding _
+  apply probEvent_bind_le_of_forall_le
+  intro high _
+  apply probEvent_bind_le_of_forall_le
+  intro exposed _
+  unfold initialExceptionHistoryPrior
+  apply probEvent_bind_le_of_forall_le
+  intro labels _
+  exact initialExceptionHistorySource_prefix_le _ adversary encoding dummy exposed high budget
+
+theorem forgeAdvantage_le_native_bound_add_cache_history (dummy : OtsReferenceWords)
+    (hdummy : ∀ lay tree leaf, TargetSum.Valid (dummy lay tree leaf)) (adversary : Adversary)
+    (budget : Nat) (hcost : HasHashQueryBound scheme adversary budget) (hbudget : budget ≤ 2 ^ 127) :
+    forgeAdvantage scheme adversary ≤
+      ENNReal.ofReal (2 * ((budget : ℝ) / 2 ^ digestBits) - ((budget : ℝ) / 2 ^ digestBits) ^ 2) +
+        (budget : ENNReal) * (11 / 2 ^ 144 : ENNReal) +
+        (Pr[fun result => result.2.2.1 = true | exceptionHistorySourceGame dummy adversary budget] + (2 ^ 700 : ENNReal)⁻¹) :=
+  (forgeAdvantage_le_native_bound_add_histories dummy hdummy adversary budget hcost hbudget).trans
+    (add_le_add le_rfl (add_le_add le_rfl (exceptionHistorySourceGame_prefix_le dummy adversary budget)))
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalTailStep.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalTailStep.lean
new file mode 100644
index 000000000..c78103acb
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalTailStep.lean
@@ -0,0 +1,126 @@
+import SphincsSecurity.Proof.Residual.RetainedResidualExceptionHistory
+import SphincsSecurity.Proof.Fts.ProposalPrefixExponential
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs sourceInputs
+set_option backward.isDefEq.respectTransparency false
+
+private theorem update_log_cap (key : SecretKey) (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) (state : CertificateMonitorState) (length : Nat) (record : ProposalExecutionRecord input)
+    (hcap : state.2.log.length ≤ signatureLimit) :
+    (certificateMonitorUpdate key budget required stopAfter input state length record).log.length ≤ signatureLimit := by
+  by_cases hactive : CertificateMonitorActive key budget input state
+  · rw [certificateMonitorUpdate, if_pos hactive]
+    have hvalid := hactive.2.2.1
+    cases input <;>
+      simp only [proposalRecordLogState, signingLogFragment, List.append_nil, List.length_append, List.length_singleton, ValidSigningStep] at hvalid ⊢ <;> omega
+  · simpa only [certificateMonitorUpdate, if_neg hactive] using hcap
+
+variable (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+  (words : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+  (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+theorem monitoredStep_log_cap (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState inputs)
+    (hcap : state.2.log.length ≤ signatureLimit)
+    (result : Option ((OracleWorld + SigningSpec).Range input) × MonitoredState inputs)
+    (hresult : monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state result ≠ 0) :
+    result.2.2.log.length ≤ signatureLimit := by
+  cases input with
+  | inl input =>
+      rw [monitoredStep, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨raw, _, hresult⟩ := hresult
+      simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      cases hr : raw.1 with
+      | none => simpa only [monitoredWorldResult, hr, Option.elim_none] using hcap
+      | some answer =>
+          simp only [monitoredWorldResult, hr, Option.elim_some]
+          exact update_log_cap key budget required stopAfter (.inl input) (monitorView state) 0 _ hcap
+  | inr message =>
+      rw [monitoredStep, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨annotation, _, hresult⟩ := hresult
+      rw [map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨raw, _, hresult⟩ := hresult
+      simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      cases hr : raw.1 with
+      | none => simpa only [monitoredSigningResult, hr] using hcap
+      | some record =>
+          simp only [monitoredSigningResult, hr]
+          exact update_log_cap key budget required stopAfter (.inr message) (monitorView state) annotation.1 _ hcap
+
+private theorem world_weight (input : OracleWorld.Domain) (state : MonitoredState inputs)
+    (raw : Option (OracleWorld.Range input) × State inputs) :
+    proposalPrefixWeight (monitoredWorldResult key budget required stopAfter input state raw).2.2.proposals
+      (monitoredWorldResult key budget required stopAfter input state raw).2.2.log.length =
+      proposalPrefixWeight state.2.proposals state.2.log.length := by
+  cases hr : raw.1 with
+  | none => simp only [monitoredWorldResult, hr, Option.elim_none]
+  | some answer =>
+      simp only [monitoredWorldResult, hr, Option.elim_some, certificateMonitorUpdate]
+      split <;> simp only [proposalRecordLogState, signingLogFragment, List.append_nil, Nat.add_zero, monitorView]
+
+private theorem signing_weight (message : Message) (annotation : Nat × Index) (state : MonitoredState inputs)
+    (record : SigningRecord) (after : State inputs) :
+    proposalPrefixWeight (monitoredSigningResult key budget required stopAfter message annotation state (some record, after)).2.2.proposals
+      (monitoredSigningResult key budget required stopAfter message annotation state (some record, after)).2.2.log.length =
+      if CertificateMonitorActive key budget (.inr message) (monitorView state) then
+        proposalPrefixWeight (state.2.proposals + annotation.1) (state.2.log.length + 1)
+      else proposalPrefixWeight state.2.proposals state.2.log.length := by
+  simp only [monitoredSigningResult, certificateMonitorUpdate]
+  split <;> simp only [proposalRecordLogState, signingLogFragment, List.length_append, List.length_singleton, monitorView]
+
+theorem expected_monitoredStep_prefixWeight_le (input : (OracleWorld + SigningSpec).Domain) (state : MonitoredState inputs)
+    (hvalid : MonitoredValid inputs state) (hinputs : requestInputs key input ⊆ inputs) :
+    (∑' result, Pr[= result | monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state] *
+      proposalPrefixWeight result.2.2.proposals result.2.2.log.length) ≤ proposalPrefixWeight state.2.proposals state.2.log.length := by
+  cases input with
+  | inl input =>
+      rw [monitoredStep, tsum_probOutput_map_mul]
+      simp only [world_weight, ENNReal.tsum_mul_right]
+      exact mul_le_of_le_one_left' tsum_probOutput_le_one
+  | inr message =>
+      rw [monitoredStep, tsum_probOutput_bind_mul]
+      simp only [tsum_probOutput_map_mul]
+      let law := lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+        (simulateQ (embed inputs state.1.memory.routing)
+          (ResidualByteFrontend.jointSigningProgram inputs key.parameter key.root state.1.memory.routing.known words selections message)) state.1
+      have hraw (annotation : Nat × Index) :
+          (∑' raw, Pr[= raw | lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+            (simulateQ (embed inputs state.1.memory.routing)
+              (ResidualByteFrontend.jointSigningProgram inputs key.parameter key.root state.1.memory.routing.known words selections message)) state.1] *
+            proposalPrefixWeight (monitoredSigningResult key budget required stopAfter message annotation state raw).2.2.proposals
+              (monitoredSigningResult key budget required stopAfter message annotation state raw).2.2.log.length) ≤
+          if CertificateMonitorActive key budget (.inr message) (monitorView state) then
+            proposalPrefixWeight (state.2.proposals + annotation.1) (state.2.log.length + 1)
+          else proposalPrefixWeight state.2.proposals state.2.log.length := by
+        apply le_trans ?_ (mul_le_of_le_one_left' (show (∑' raw, Pr[= raw | law]) ≤ 1 from tsum_probOutput_le_one))
+        rw [← ENNReal.tsum_mul_right]
+        apply ENNReal.tsum_le_tsum
+        intro raw
+        by_cases hr : Pr[= raw | lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+            (simulateQ (embed inputs state.1.memory.routing)
+              (ResidualByteFrontend.jointSigningProgram inputs key.parameter key.root state.1.memory.routing.known words selections message)) state.1] = 0
+        · simp only [law, hr, zero_mul, le_refl]
+        · rw [SPMF.probOutput_eq_apply] at hr
+          obtain ⟨record, heq⟩ := lazyRun_jointSigningProgram_some key.parameter inputs hencoding words publicReplies selections rows
+            state.1.memory.routing key.root message
+            (by simpa only [publicDigestLoop_eq] using digestInputs_of_request key inputs words selections message state.1.memory.routing.known hinputs)
+            state.1 hvalid.1 hvalid.2 raw hr
+          have hpair : raw = (some record, raw.2) := Prod.ext heq rfl
+          rw [hpair, signing_weight]
+      apply le_trans (ENNReal.tsum_le_tsum fun annotation => mul_le_mul' le_rfl (hraw annotation))
+      by_cases hactive : CertificateMonitorActive key budget (.inr message) (monitorView state)
+      · simp only [if_pos hactive, SPMF.probOutput_liftM]
+        rw [signingAnnotation, if_pos hactive, ← PMF.monad_bind_eq_bind, tsum_probOutput_bind_mul]
+        simp_rw [← PMF.monad_map_eq_map, tsum_probOutput_map_mul]
+        simp only [ENNReal.tsum_mul_right, PMF.probOutput_eq_apply, PMF.tsum_coe, one_mul]
+        exact (expected_proposalPrefixWeight state.2.proposals state.2.log.length hactive.2.2.1).le
+      · simp only [if_neg hactive, ENNReal.tsum_mul_right]
+        exact mul_le_of_le_one_left' tsum_probOutput_le_one
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalWord.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalWord.lean
new file mode 100644
index 000000000..870b85543
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualProposalWord.lean
@@ -0,0 +1,101 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.ProposalLengthProjection
+import SphincsSecurity.Proof.Residual.RetainedObservation
+import SphincsSecurity.Proof.Fts.TerminalProposalWord
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp ENNReal
+set_option backward.isDefEq.respectTransparency false
+
+theorem pmfLift_map {Result Other : Type} (law : PMF Result) (f : Result → Other) :
+    (liftM (law.map f) : SPMF Other) = f <$> (liftM law : SPMF Result) := by
+  rw [← PMF.monad_map_eq_map]
+  exact liftM_map _ _
+
+theorem pmfLift_bind {Result Other : Type} (law : PMF Result) (next : Result → PMF Other) :
+    (liftM (law.bind next) : SPMF Other) = ((liftM law : SPMF Result) >>= fun result => liftM (next result)) := by
+  rw [← PMF.monad_bind_eq_bind]
+  exact liftM_bind _ _
+
+noncomputable def attachRejectedWord {Result : Type} (law : SPMF Result) (rejected : PMF Index) :
+    SPMF (List Index × Result) :=
+  law >>= fun result => (fun word => (word, result)) <$>
+    (liftM (rejectedProposalWord rejected targetProposalAcceptance targetProposalAcceptance_ne_zero
+      targetProposalAcceptance_lt_one.le) : SPMF (List Index))
+
+theorem attachRejectedWord_record {Result : Type} (law : SPMF Result) (rejected : PMF Index) :
+    Prod.snd <$> attachRejectedWord law rejected = law := by
+  rw [attachRejectedWord, map_bind]
+  simp only [map_eq_bind_pure_comp, Function.comp_def, bind_assoc, pure_bind,
+    RetainedObservation.lift_bind_const, bind_pure]
+
+theorem attachRejectedWord_lift {Result : Type} (law : PMF Result) (rejected : PMF Index) :
+    attachRejectedWord (liftM law) rejected =
+      (liftM (recordProposalBridge law rejected targetProposalAcceptance targetProposalAcceptance_ne_zero
+        targetProposalAcceptance_lt_one.le) : SPMF (List Index × Result)) := by
+  rw [attachRejectedWord, recordProposalBridge, pmfLift_bind]
+  simp only [pmfLift_map]
+
+theorem attachRejectedWord_length {Result : Type} (law : SPMF Result) (rejected : PMF Index) :
+    (fun result => (result.1.length + 1, result.2)) <$> attachRejectedWord law rejected =
+      ((liftM (proposalBlockLength targetProposalAcceptance targetProposalAcceptance_ne_zero
+          targetProposalAcceptance_lt_one.le) : SPMF Nat) >>= fun length =>
+        (fun result => (length, result)) <$> law) := by
+  rw [attachRejectedWord, map_bind]
+  have hword (result : Result) :
+      (fun item : List Index × Result => (item.1.length + 1, item.2)) <$>
+          ((fun word => (word, result)) <$>
+            (liftM (rejectedProposalWord rejected targetProposalAcceptance targetProposalAcceptance_ne_zero
+              targetProposalAcceptance_lt_one.le) : SPMF (List Index))) =
+        (fun length => (length, result)) <$>
+          (liftM (proposalBlockLength targetProposalAcceptance targetProposalAcceptance_ne_zero
+            targetProposalAcceptance_lt_one.le) : SPMF Nat) := by
+    rw [Functor.map_map]
+    calc
+      _ = (fun length => (length, result)) <$>
+          ((fun word : List Index => word.length + 1) <$>
+            (liftM (rejectedProposalWord rejected targetProposalAcceptance targetProposalAcceptance_ne_zero
+              targetProposalAcceptance_lt_one.le) : SPMF (List Index))) := by rw [Functor.map_map]
+      _ = _ := by
+        rw [← pmfLift_map, rejectedProposalWord_blockLength]
+  simp_rw [hword]
+  simp only [map_eq_bind_pure_comp, Function.comp_def]
+  exact RetainedObservation.bind_comm _ _ _
+
+theorem attachRejectedWord_complete {Result Original : Type}
+    (law : SPMF Result) (label : Result → Index) (record : PMF Original) (originalLabel : Original → Index)
+    (hindex : label <$> law = (liftM (record.map originalLabel) : SPMF Index))
+    (hcap : ∀ index, targetProposalAcceptance * (record.map originalLabel) index ≤ PMF.uniformOfFintype Index index)
+    (total : Nat) (consumed : List Index) :
+    (attachRejectedWord law
+      (proposalResidualLaw (PMF.uniformOfFintype Index) (record.map originalLabel) targetProposalAcceptance
+        targetProposalAcceptance_lt_one hcap) >>= fun result =>
+      (liftM (completeProposalWord (PMF.uniformOfFintype Index) total
+        (consumed ++ (result.1 ++ [label result.2]))) : SPMF (List Index))) =
+      (liftM (completeProposalWord (PMF.uniformOfFintype Index) total consumed) : SPMF (List Index)) := by
+  let rejected := proposalResidualLaw (PMF.uniformOfFintype Index) (record.map originalLabel) targetProposalAcceptance
+    targetProposalAcceptance_lt_one hcap
+  have hproject :
+      (attachRejectedWord law rejected >>= fun result =>
+        (liftM (completeProposalWord (PMF.uniformOfFintype Index) total
+          (consumed ++ (result.1 ++ [label result.2]))) : SPMF (List Index))) =
+      (attachRejectedWord (liftM record) rejected >>= fun result =>
+        (liftM (completeProposalWord (PMF.uniformOfFintype Index) total
+          (consumed ++ (result.1 ++ [originalLabel result.2]))) : SPMF (List Index))) := by
+    simp only [attachRejectedWord, bind_assoc, bind_map_left]
+    calc
+      _ = (label <$> law) >>= fun index =>
+          (liftM (rejectedProposalWord rejected targetProposalAcceptance targetProposalAcceptance_ne_zero
+            targetProposalAcceptance_lt_one.le) : SPMF (List Index)) >>= fun word =>
+              (liftM (completeProposalWord (PMF.uniformOfFintype Index) total
+                (consumed ++ (word ++ [index]))) : SPMF (List Index)) := by rw [bind_map_left]
+      _ = _ := by rw [hindex, pmfLift_map, bind_map_left]
+  change (attachRejectedWord law rejected >>= _) = _
+  rw [hproject, attachRejectedWord_lift, ← pmfLift_bind]
+  change (liftM ((cappedRecordProposalBridge (PMF.uniformOfFintype Index) record originalLabel
+    targetProposalAcceptance targetProposalAcceptance_ne_zero targetProposalAcceptance_lt_one hcap).bind
+      (fun result => completeProposalWord (PMF.uniformOfFintype Index) total
+        (consumed ++ (result.1 ++ [originalLabel result.2])))) : SPMF (List Index)) = _
+  rw [complete_cappedRecordProposalBridge_prefix]
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualQueryPotential.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualQueryPotential.lean
new file mode 100644
index 000000000..ffb2341fe
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualQueryPotential.lean
@@ -0,0 +1,88 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.PrimitiveMessagePotential
+import SphincsSecurity.Proof.Residual.RetainedResidualHazard
+import SphincsSecurity.Proof.Residual.RetainedResidualProbeBudget
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing)
+open ResidualByteFrontend (HiddenCandidateBound)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs sourceInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+  (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem prob_checkedHashQuery_message_stop (routing : Routing) (input : inputs) (state : State inputs)
+    (hmessage : FtsProbeSimulation.MessageHashInput parameter input.val)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) :
+    Pr[fun result => result.1 = none |
+      lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+        (simulateQ (embed inputs routing)
+          (ResidualByteFrontend.checkedHashQuery
+            (PublicEncodingMatch.Match parameter (knownEncodingMessage routing.known) words selections) input)) state] = 0 := by
+  rw [checkedHashQuery_message parameter inputs words selections routing input hmessage,
+    lazyRun_hashQuery_message parameter inputs hencoding words publicReplies selections rows routing input hmessage state hcovered,
+    probEvent_map]
+  simp only [Function.comp_def, reduceCtorEq, probEvent_False]
+
+theorem checkedHashQuery_joint_payment (routing : Routing) (input : inputs) (state : State inputs) (q : Nat)
+    (hselect : ∀ position, FirstSuccessTable.select decodeEncodingOutput (fun counter => rows (position, counter)) = selections position)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hcandidates : HiddenCandidateBound words routing.disclosed (project state))
+    (hclean : ResidualByteFrontend.ReplyClean
+      (PublicEncodingMatch.Match parameter (knownEncodingMessage routing.known) words selections) state.memory.external.cache)
+    (hresources : ProbeMessageBound state.memory) (hquery : state.memory.external.hashCalls + 1 ≤ q)
+    (hbudget : 2 * q ≤ 2 ^ digestBits) :
+    let probability := (Pr[fun result => result.1 = none |
+      lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+        (simulateQ (embed inputs routing)
+          (ResidualByteFrontend.checkedHashQuery
+            (PublicEncodingMatch.Match parameter (knownEncodingMessage routing.known) words selections) input)) state]).toReal
+    let afterProbes := (charge parameter words routing.disclosed routing.known input.val state.memory.external).probes
+    probability + (1 - probability) *
+      ((if FtsProbeSimulation.MessageHashInput parameter input.val then (2 ^ digestBits : ℝ)⁻¹ else 0) +
+        PrimitiveMessagePotential.value (2 ^ digestBits) afterProbes ((q : ℝ) - (state.memory.external.hashCalls + 1))) ≤
+      PrimitiveMessagePotential.value (2 ^ digestBits) state.memory.external.probes ((q : ℝ) - state.memory.external.hashCalls) := by
+  have hspace : (0 : ℝ) < 2 ^ digestBits := by positivity
+  have hp : state.memory.external.probes ≤ state.memory.external.hashCalls := by
+    exact (Nat.le_add_right _ _).trans hresources
+  have hpReal : (state.memory.external.probes : ℝ) ≤ state.memory.external.hashCalls := by exact_mod_cast hp
+  have hqReal : (state.memory.external.hashCalls : ℝ) + 1 ≤ q := by exact_mod_cast hquery
+  have hbudgetReal : 2 * (q : ℝ) ≤ 2 ^ digestBits := by exact_mod_cast hbudget
+  have hremaining : (0 : ℝ) ≤ q - (state.memory.external.hashCalls + 1) := by linarith
+  have hsum : (state.memory.external.probes : ℝ) + (q - (state.memory.external.hashCalls + 1)) + 1 < 2 ^ digestBits := by
+    linarith
+  have hmin : state.memory.external.probes < 2 ^ digestBits := by
+    have hpos : 0 < 2 ^ digestBits := by positivity
+    omega
+  have hleft : ((q : ℝ) - (state.memory.external.hashCalls + 1)) + 1 = q - state.memory.external.hashCalls := by ring
+  dsimp only
+  by_cases hmessage : FtsProbeSimulation.MessageHashInput parameter input.val
+  · rw [prob_checkedHashQuery_message_stop parameter inputs hencoding words publicReplies selections rows routing input state hmessage hcovered,
+      ENNReal.toReal_zero, zero_add, sub_zero, one_mul, if_pos hmessage,
+      charge_message_probes parameter words routing input.val hmessage state.memory.external]
+    have h := PrimitiveMessagePotential.message_payment (2 ^ digestBits) state.memory.external.probes
+      ((q : ℝ) - (state.memory.external.hashCalls + 1)) hspace (by positivity) hremaining (by linarith)
+    simpa only [one_div, hleft] using h
+  · rw [if_neg hmessage, zero_add]
+    have hprob := prob_checkedHashQuery_stop_le parameter inputs hencoding words publicReplies selections rows routing input state
+      hselect ha hcovered hcandidates hclean
+    have hfinite : ResidualByteFrontend.probeHazard state.memory.external.probes ≠ ⊤ :=
+      ne_top_of_le_ne_top (by simp) tsub_le_self
+    have hprobReal := ENNReal.toReal_mono hfinite hprob
+    rw [ResidualByteFrontend.probeHazard, PrimitiveMessagePotential.toReal_hazard _ _ hmin] at hprobReal
+    have hspaceCast : ((2 ^ digestBits : Nat) : ℝ) = 2 ^ digestBits := by push_cast; rfl
+    rw [hspaceCast] at hprobReal
+    have hpaid : ((charge parameter words routing.disclosed routing.known input.val state.memory.external).probes : ℝ) ≤
+        state.memory.external.probes + 1 := by
+      exact_mod_cast charge_probes_le parameter words routing.disclosed routing.known input.val state.memory.external
+    have h := PrimitiveMessagePotential.nonmessage_step (2 ^ digestBits) state.memory.external.probes _
+      ((q : ℝ) - (state.memory.external.hashCalls + 1)) _ hremaining hpaid hsum hprobReal
+    simpa only [hleft] using h
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualRecovery.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualRecovery.lean
new file mode 100644
index 000000000..c7ae1d97d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualRecovery.lean
@@ -0,0 +1,282 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualContext
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+  signDigestLoop signAfterDigest sequenceFin chainWalk
+set_option backward.isDefEq.respectTransparency false
+
+theorem Context.graph_eq {inputs : Finset HashInput} (context : Context inputs) :
+    canonicalGraphLabels context.key.parameter context.key.otsSecret context.key.ftsSecret context.oracle = context.graph :=
+  canonicalGraphLabels_programmedHash _ _ _ _ _
+
+theorem Context.actual_graph {inputs : Finset HashInput} (context : Context inputs) (position : Position)
+    (hbound : position.TreeBound) :
+    context.actual (.graph position) = honestValue context.oracle context.key.parameter context.key.otsSecret context.key.ftsSecret position := by
+  change truncateHash (context.graph position) = _
+  rw [← context.graph_eq, canonicalGraphLabels_eq_honest _ _ _ _ position hbound]
+  rfl
+
+theorem Context.input_honest {inputs : Finset HashInput} (context : Context inputs) (position : Position)
+    (hbound : position.TreeBound) :
+    inputOf context.key.parameter context.actual position =
+      honestInput context.oracle context.key.parameter context.key.otsSecret context.key.ftsSecret position := by
+  rw [Context.actual, inputOf_canonical]
+  apply canonicalGraphInput_eq_honest _ _ _ _ position (hbound.valid position)
+  intro child hchild
+  exact context.actual_graph child (hbound.child hchild)
+
+theorem Compatible.not_payload_collision {inputs : Finset HashInput} {context : Context inputs} {memory : Memory}
+    (hcompatible : Compatible context memory) (position : Position) (hbound : position.TreeBound) (payload : HashInput)
+    (hne : payload ≠ honestPayload context.oracle context.key.parameter context.key.otsSecret context.key.ftsSecret position)
+    (hcached : memory.external.cache (tweakableHashInput context.key.parameter position.domain payload) ≠ none)
+    (hvalue : truncateHash (context.oracle (tweakableHashInput context.key.parameter position.domain payload)) =
+      honestValue context.oracle context.key.parameter context.key.otsSecret context.key.ftsSecret position) : False := by
+  obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp hcached
+  apply hcompatible.structural _ answer hanswer
+  refine ⟨position, ⟨payload, rfl⟩, Or.inr ⟨?_, ?_⟩⟩
+  · rw [context.input_honest position hbound]
+    intro heq
+    exact hne (tweakableHashInput_injective context.key.parameter position.domain_inRange position.domain_inRange heq).2
+  · rw [hcompatible.cached _ _ hanswer, hvalue, context.actual_graph position hbound]
+
+private theorem foldPosition_bound (height level index : Nat) (hlevel : level < height) (hindex : index < 2 ^ height) :
+    2 ^ (level + 1) * (index / 2 ^ (level + 1) + 1) ≤ 2 ^ height := by
+  have hpow : (2 : Nat) ^ height = 2 ^ (level + 1) * 2 ^ (height - (level + 1)) := by
+    rw [← pow_add, Nat.add_sub_of_le (Nat.succ_le_of_lt hlevel)]
+  have hdiv : index / 2 ^ (level + 1) < 2 ^ (height - (level + 1)) := by
+    apply (Nat.div_lt_iff_lt_mul (by positivity)).mpr
+    simpa only [hpow, Nat.mul_comm] using hindex
+  calc
+    _ ≤ 2 ^ (level + 1) * 2 ^ (height - (level + 1)) := Nat.mul_le_mul_left _ (Nat.succ_le_of_lt hdiv)
+    _ = _ := hpow.symm
+
+theorem Compatible.layer_honest {inputs : Finset HashInput} {context : Context inputs} {memory : Memory}
+    (hcompatible : Compatible context memory) (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 context.oracle
+      (otsLeaf context.key.parameter lay tree leafIdx message counter values) = some leafValue)
+    (hfold : foldValue context.oracle context.key.parameter lay tree leafIdx path leafValue (layerHeight lay) =
+      honestNode context.oracle context.key.parameter lay tree (context.key.otsSecret lay tree) (layerHeight lay) 0)
+    (hotsRun : CachedRun memory.external.cache context.oracle
+      (otsLeaf context.key.parameter lay tree leafIdx message counter values))
+    (hfoldRun : CachedRun memory.external.cache context.oracle
+      (treeFold context.key.parameter lay tree leafIdx path (layerHeight lay) leafValue)) :
+    HonestLayerOpening context.oracle context.key.parameter context.key.otsSecret lay tree leafIdx message counter values path := by
+  cases hencode : evalWithAnswerFn context.oracle (encode context.key.parameter lay tree leafIdx message counter) with
+  | none =>
+      simp only [otsLeaf, evalWithAnswerFn_bind, hencode, evalWithAnswerFn_pure, reduceCtorEq] at hleaf
+  | some codeword =>
+      rcases treeFold_extract context.oracle context.key.parameter lay tree (context.key.otsSecret lay tree) leafIdx path leafValue
+          (layerHeight lay) (by simpa only [Nat.div_eq_of_lt hleafIdx] using hfold) with
+        ⟨hleafValue, hpath⟩ | ⟨level, hlevel, hhit⟩
+      · have hleafHonest : evalWithAnswerFn context.oracle
+            (otsLeaf context.key.parameter lay tree leafIdx message counter values) =
+            some (honestNode context.oracle context.key.parameter lay tree (context.key.otsSecret lay tree) 0 leafIdx.val) := by
+          rw [hleaf, hleafValue]
+        rcases otsLeaf_extract context.oracle context.key.parameter lay tree (context.key.otsSecret lay tree) leafIdx
+            message counter values codeword hencode hleafHonest with hvalues | hhit | ⟨chainIdx, offset, hrange, hoffset, hhit⟩
+        · exact ⟨codeword, hencode, hvalues, hpath⟩
+        · exact (hcompatible.not_payload_collision (.leaf lay tree leafIdx) (by trivial) _ hhit.1
+            (hotsRun _ (otsLeaf_leaf_query_mem context.oracle context.key.parameter lay tree leafIdx message counter values codeword hencode))
+            (by simpa only [Position.domain, honestValue_leaf] using hhit.2)).elim
+        · apply False.elim
+          apply hcompatible.not_payload_collision (.chain lay tree leafIdx chainIdx ⟨_, hrange⟩) (by trivial) _
+          · simpa only [honestPayload] using fun heq => hhit.1 (digestBytes_injective heq)
+          · exact hotsRun _ (otsLeaf_chain_query_mem context.oracle context.key.parameter lay tree leafIdx message counter values
+              codeword hencode chainIdx offset hoffset hrange)
+          · simpa only [Position.domain, honestValue_chain] using hhit.2
+      · 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 False.elim
+        apply hcompatible.not_payload_collision (.node lay tree ⟨level, hlevelMax⟩ ⟨_, hnodeIdx⟩)
+          (foldPosition_bound maxLayerHeight level leafIdx.val hlevelMax leafIdx.isLt) _ hhit.1
+        · exact hfoldRun _ (treeFold_query_mem context.oracle context.key.parameter lay tree leafIdx path leafValue
+            (layerHeight lay) level hlevel)
+        · simpa only [Position.domain, honestValue_node] using hhit.2
+
+theorem Compatible.no_hidden_input {inputs : Finset HashInput} {context : Context inputs} {memory : Memory}
+    (hcompatible : Compatible context memory) (position : Position)
+    (hcached : memory.external.cache (inputOf context.key.parameter context.actual position) ≠ none) :
+    ¬HasHiddenChild context.words memory.routing.disclosed position := by
+  obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp hcached
+  intro hhidden
+  exact hcompatible.structural _ _ hanswer ⟨position, ⟨_, rfl⟩, Or.inl ⟨hhidden, rfl⟩⟩
+
+theorem Context.words_valid {inputs : Finset HashInput} (context : Context inputs)
+    (hdummy : ∀ lay tree leaf, TargetSum.Valid (context.dummy lay tree leaf)) :
+    ∀ lay tree leaf, TargetSum.Valid (context.words lay tree leaf) := by
+  rw [Context.words, referencePrefix_words context.key inputs context.encoding context.graph context.auxiliary context.auxiliary_valid]
+  exact canonicalReferenceWords_valid context.key context.oracle context.dummy hdummy
+
+theorem Compatible.layer_word {inputs : Finset HashInput} {context : Context inputs} {memory : Memory}
+    (hcompatible : Compatible context memory) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex)
+    (message : Digest) (counter : Counter) (values : ChainIndex → Digest) (codeword : Encoding)
+    (hword : TargetSum.Valid (context.words lay tree leafIdx))
+    (hencode : evalWithAnswerFn context.oracle (encode context.key.parameter lay tree leafIdx message counter) = some codeword)
+    (hvalues : ∀ chain, values chain = honestChain context.oracle context.key.parameter lay tree leafIdx chain
+      (context.key.otsSecret lay tree leafIdx chain) (codeword chain).val)
+    (hrun : CachedRun memory.external.cache context.oracle (otsLeaf context.key.parameter lay tree leafIdx message counter values)) :
+    codeword = context.words lay tree leafIdx := by
+  apply Eq.symm
+  apply TargetSum.eq_of_le_of_valid hword (valid_of_eval_encode_eq_some _ _ _ _ _ _ _ _ hencode)
+  intro chain
+  by_contra hnot
+  have hlt : (codeword chain).val < (context.words lay tree leafIdx chain).val := by omega
+  have hrange : (codeword chain).val < chainLength - 1 := by
+    have := (context.words lay tree leafIdx chain).isLt
+    omega
+  let position : Position := .chain lay tree leafIdx chain ⟨(codeword chain).val, hrange⟩
+  have hquery := hrun _ (otsLeaf_chain_query_mem context.oracle context.key.parameter lay tree leafIdx message counter values
+    codeword hencode chain 0 (by omega) (by omega))
+  simp only [Nat.add_zero, walkValue, chainWalk, evalWithAnswerFn_pure] at hquery
+  have hinput : inputOf context.key.parameter context.actual position =
+      tweakableHashInput context.key.parameter position.domain (digestBytes (values chain)) := by
+    rw [context.input_honest position (by trivial)]
+    change tweakableHashInput context.key.parameter position.domain
+      (digestBytes (honestChain context.oracle context.key.parameter lay tree leafIdx chain
+        (context.key.otsSecret lay tree leafIdx chain) (codeword chain).val)) = _
+    rw [hvalues chain]
+  apply hcompatible.no_hidden_input position (by rw [hinput]; exact hquery)
+  refine ⟨CanonicalCoordinate.chainChild lay tree leafIdx chain ⟨_, hrange⟩, ?_, ?_⟩
+  · rw [CanonicalCoordinate.slots_chain]
+    exact List.mem_singleton_self _
+  · exact (CanonicalCoordinate.hidden_chain_child_iff context.words memory.routing.disclosed lay tree leafIdx chain _).mpr hlt
+
+theorem Compatible.layer_reference {inputs : Finset HashInput} {context : Context inputs} {memory : Memory}
+    (hcompatible : Compatible context memory) (lay : Layer) (tree : TreeIndex) (leafIdx : LeafIndex)
+    (message : Digest) (counter : Counter) (values : ChainIndex → Digest) (path : Nat → Digest)
+    (hword : TargetSum.Valid (context.words lay tree leafIdx))
+    (hhonest : HonestLayerOpening context.oracle context.key.parameter context.key.otsSecret lay tree leafIdx message counter values path)
+    (hrun : CachedRun memory.external.cache context.oracle (otsLeaf context.key.parameter lay tree leafIdx message counter values)) :
+    ∃ selected, context.auxiliary.selections ⟨lay, tree, leafIdx⟩ = some selected ∧
+      message = canonicalGraphMessage context.graph ⟨lay, tree, leafIdx⟩ ∧
+      counter = BitVec.ofNat counterBits selected.1.val ∧
+      (∀ chain, values chain = honestChain context.oracle context.key.parameter lay tree leafIdx chain
+        (context.key.otsSecret lay tree leafIdx chain) (context.words lay tree leafIdx chain).val) ∧
+      ∀ level, level < layerHeight lay → path level =
+        honestNode context.oracle context.key.parameter lay tree (context.key.otsSecret lay tree) level
+          (Nat.xor (leafIdx.val / 2 ^ level) 1) := by
+  obtain ⟨codeword, hencode, hvalues, hpath⟩ := hhonest
+  have hcodeword := hcompatible.layer_word lay tree leafIdx message counter values codeword hword hencode hvalues hrun
+  rw [hcodeword] at hencode hvalues
+  let position : EncodingPosition := ⟨lay, tree, leafIdx⟩
+  let input := tweakableHashInput context.key.parameter position.domain (digestBytes message ++ counterBytes counter)
+  have hreference : PublicEncodingMatch.referenceInput context.key.parameter (canonicalGraphMessage context.graph)
+      context.auxiliary.selections position = some input := by
+    by_contra hnot
+    obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp (CachedRun.otsLeaf_encode_cached hrun)
+    apply hcompatible.encoding _ _ hanswer
+    refine ⟨position, ⟨_, rfl⟩, hnot, ?_⟩
+    rw [hcompatible.cached _ _ hanswer]
+    exact decode_of_eval_encode_eq_some _ _ _ _ _ _ _ _ hencode
+  cases hselected : context.auxiliary.selections position with
+  | none => simp only [PublicEncodingMatch.referenceInput, hselected, Option.map_none, reduceCtorEq] at hreference
+  | some selected =>
+      have hinput : encodingRetryInput context.key.parameter position (canonicalGraphMessage context.graph position) selected.1.val = input := by
+        simpa only [PublicEncodingMatch.referenceInput, hselected, Option.map_some, Option.some.injEq] using hreference
+      have hpayload := (tweakableHashInput_injective context.key.parameter (by trivial) (by trivial) hinput).2
+      obtain ⟨hmessage, hcounter⟩ := List.append_inj hpayload (by simp [digestBytes_length])
+      exact ⟨selected, rfl, (digestBytes_injective hmessage).symm, (bytesLE_injective hcounter).symm, hvalues, hpath⟩
+
+theorem Compatible.ftsTree_honest {inputs : Finset HashInput} {context : Context inputs} {memory : Memory}
+    (hcompatible : Compatible context memory) (index : Index) (leaves : IndexGroup → FtsLeaf)
+    (secrets : FtsTree → Digest) (paths : FtsTree → Fin ftsTreeHeight → Digest) (tree : FtsTree)
+    (hfold : ftsFoldValue context.oracle context.key.parameter index tree (leaves (ftsIndexOf tree)) (paths tree)
+      (truncateHash (context.oracle (tweakableHashInput context.key.parameter
+        (.ftsLeaf index tree (leaves (ftsIndexOf tree))) (digestBytes (secrets tree))))) ftsTreeHeight =
+      honestFtsNode context.oracle context.key.parameter index tree (context.key.ftsSecret index tree) ftsTreeHeight 0)
+    (hrun : CachedRun memory.external.cache context.oracle (ftsRecover context.key.parameter index leaves secrets paths)) :
+    secrets tree = context.key.ftsSecret index tree (leaves (ftsIndexOf tree)) ∧
+      ∀ level (hlevel : level < ftsTreeHeight), paths tree ⟨level, hlevel⟩ =
+        honestFtsNode context.oracle context.key.parameter index tree (context.key.ftsSecret index tree) level
+          (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level) 1) := by
+  let leafIdx := leaves (ftsIndexOf tree)
+  let leafValue := truncateHash (context.oracle (tweakableHashInput context.key.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 context.oracle context.key.parameter index tree (context.key.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 context.oracle context.key.parameter index tree (context.key.ftsSecret index tree)
+      leafIdx (secrets tree) hleafValue with hsecret | hhit
+    · refine ⟨hsecret, ?_⟩
+      intro level hlevel
+      simpa only [ftsSibling, dif_pos hlevel, leafIdx] using hpath level hlevel
+    · apply False.elim
+      apply hcompatible.not_payload_collision (.ftsLeaf index tree leafIdx) (by trivial) _
+      · simpa only [honestPayload] using fun heq => hhit.1 (digestBytes_injective heq)
+      · exact hrun _ (ftsRecover_leaf_query_mem context.oracle context.key.parameter index leaves secrets paths tree)
+      · simpa only [Position.domain, honestValue_ftsLeaf] using hhit.2
+  · have hnodeIdx : leafIdx.val / 2 ^ (level + 1) < 2 ^ ftsTreeHeight :=
+      lt_of_le_of_lt (Nat.div_le_self _ _) leafIdx.isLt
+    apply False.elim
+    apply hcompatible.not_payload_collision (.ftsNode index tree ⟨level, hlevel⟩ ⟨_, hnodeIdx⟩)
+      (foldPosition_bound ftsTreeHeight level leafIdx.val hlevel leafIdx.isLt) _ hhit.1
+    · exact hrun _ (ftsRecover_fold_query_mem context.oracle context.key.parameter index leaves secrets paths tree level hlevel)
+    · simpa only [Position.domain, honestValue_ftsNode] using hhit.2
+
+theorem Compatible.ftsRecover_honest {inputs : Finset HashInput} {context : Context inputs} {memory : Memory}
+    (hcompatible : Compatible context memory) (index : Index) (leaves : IndexGroup → FtsLeaf)
+    (secrets : FtsTree → Digest) (paths : FtsTree → Fin ftsTreeHeight → Digest)
+    (hrecover : evalWithAnswerFn context.oracle (ftsRecover context.key.parameter index leaves secrets paths) =
+      honestFtsKey context.oracle context.key.parameter index (context.key.ftsSecret index))
+    (hrun : CachedRun memory.external.cache context.oracle (ftsRecover context.key.parameter index leaves secrets paths)) :
+    ∀ tree, secrets tree = context.key.ftsSecret index tree (leaves (ftsIndexOf tree)) ∧
+      ∀ level (hlevel : level < ftsTreeHeight), paths tree ⟨level, hlevel⟩ =
+        honestFtsNode context.oracle context.key.parameter index tree (context.key.ftsSecret index tree) level
+          (Nat.xor ((leaves (ftsIndexOf tree)).val / 2 ^ level) 1) := by
+  let roots : FtsTree → Digest := fun tree => evalWithAnswerFn context.oracle
+    (ftsFold context.key.parameter index tree (leaves (ftsIndexOf tree)) (paths tree) ftsTreeHeight
+      (evalWithAnswerFn context.oracle (ftsLeafHash context.key.parameter index tree (leaves (ftsIndexOf tree)) (secrets tree))))
+  by_cases hpayload : ftsRootsPayload roots =
+      honestPayload context.oracle context.key.parameter context.key.otsSecret context.key.ftsSecret (.ftsRoots index)
+  · have hrootValues : roots = fun tree =>
+        honestFtsNode context.oracle context.key.parameter index tree (context.key.ftsSecret index tree) ftsTreeHeight 0 := by
+      apply TargetSum.ftsRootsPayload_injective
+      simpa only [roots, honestPayload] using hpayload
+    intro tree
+    apply hcompatible.ftsTree_honest index leaves secrets paths tree _ hrun
+    have := congrFun hrootValues tree
+    simpa only [roots, evalWithAnswerFn_bind, ftsLeafHash, eval_tweakableHash, ftsFoldValue] using this
+  · apply False.elim
+    apply hcompatible.not_payload_collision (.ftsRoots index) (by trivial) _ hpayload
+    · apply hrun
+      have hmem := ftsRecover_roots_query_mem context.oracle context.key.parameter index leaves secrets paths
+      convert hmem using 1
+      all_goals simp [roots, Position.domain]
+    · rw [honestValue_ftsRoots]
+      simp only [ftsRecover, evalWithAnswerFn_bind, evalWithAnswerFn_sequenceFin, eval_tweakableHash] at hrecover
+      change truncateHash (context.oracle (tweakableHashInput context.key.parameter (.ftsRoots index)
+        (ftsRootsPayload roots))) = _
+      dsimp only [roots]
+      simpa only [evalWithAnswerFn_bind] using hrecover
+
+theorem Compatible.ftsRecover_disclosed {inputs : Finset HashInput} {context : Context inputs} {memory : Memory}
+    (hcompatible : Compatible context memory) (index : Index) (leaves : IndexGroup → FtsLeaf)
+    (secrets : FtsTree → Digest) (paths : FtsTree → Fin ftsTreeHeight → Digest)
+    (hrecover : evalWithAnswerFn context.oracle (ftsRecover context.key.parameter index leaves secrets paths) =
+      honestFtsKey context.oracle context.key.parameter index (context.key.ftsSecret index))
+    (hrun : CachedRun memory.external.cache context.oracle (ftsRecover context.key.parameter index leaves secrets paths)) :
+    ∀ tree, memory.routing.disclosed index tree (leaves (ftsIndexOf tree)) := by
+  have hhonest := hcompatible.ftsRecover_honest index leaves secrets paths hrecover hrun
+  intro tree
+  by_contra hhidden
+  apply hcompatible.no_hidden_input (.ftsLeaf index tree (leaves (ftsIndexOf tree)))
+  · rw [context.input_honest _ (by trivial)]
+    change memory.external.cache (tweakableHashInput context.key.parameter (.ftsLeaf index tree (leaves (ftsIndexOf tree)))
+      (digestBytes (context.key.ftsSecret index tree (leaves (ftsIndexOf tree))))) ≠ none
+    rw [← (hhonest tree).1]
+    exact hrun _ (ftsRecover_leaf_query_mem context.oracle context.key.parameter index leaves secrets paths tree)
+  · exact ⟨.ftsStart index tree (leaves (ftsIndexOf tree)), List.mem_singleton_self _, hhidden⟩
+
+theorem Context.layer_message {inputs : Finset HashInput} (context : Context inputs) (index : Index) (lay : Layer) :
+    canonicalGraphMessage context.graph ⟨lay, treeIndexAt index lay, leafIndexAt index lay⟩ =
+      evalWithAnswerFn context.oracle (layerMessage context.key index lay) := by
+  rw [← context.graph_eq, canonicalGraphMessage_eq, layerMessage_referenceIndex]
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualReplay.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualReplay.lean
new file mode 100644
index 000000000..9cd85ebc6
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualReplay.lean
@@ -0,0 +1,98 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualRecovery
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+  signDigestLoop signAfterDigest sequenceFin chainWalk
+set_option backward.isDefEq.respectTransparency false
+
+theorem Compatible.honest_public_plan {inputs : Finset HashInput} {context : Context inputs} {memory : Memory}
+    (hcompatible : Compatible context memory) (hdummy : ∀ lay tree leaf, TargetSum.Valid (context.dummy lay tree leaf))
+    (index : Index) (leaves : IndexGroup → FtsLeaf) (signature : Signature)
+    (hfull : FullyHonestOpening context.oracle memory.external.cache context.key index leaves signature) :
+    (publicSignPlan memory.routing.known context.words context.auxiliary.selections signature.randomness index leaves).1.map
+      (fun plan => plan.finish (fun tree => context.key.ftsSecret index tree (leaves (ftsIndexOf tree)))) = some signature := by
+  have hagrees : PublicAgreement context.words memory.routing.disclosed memory.routing.known
+      (CanonicalCoordinate.value context.key.otsSecret context.key.ftsSecret
+        (canonicalGraphLabels context.key.parameter context.key.otsSecret context.key.ftsSecret context.oracle)) := by
+    rw [context.graph_eq]
+    exact hcompatible.agrees
+  have hfrontier := knownFrontier_eq context.key.otsSecret context.key.ftsSecret context.graph context.words
+    memory.routing.disclosed memory.routing.known hcompatible.agrees
+  rw [← context.graph_eq, canonicalGraphLabels_frontier context.key.parameter context.key.otsSecret context.key.ftsSecret
+    context.oracle context.words context.key.root] at hfrontier
+  let parts : Layer → LayerPart := fun lay =>
+    (signature.counter lay, signature.chainValue lay,
+      knownTreePath memory.routing.known lay (treeIndexAt index lay) (leafIndexAt index lay))
+  have hlayers : ∀ lay, (publicSignLayer memory.routing.known context.words context.auxiliary.selections index lay).1 = some (parts lay) := by
+    intro lay
+    obtain ⟨selected, hselected, _, hcounter, hvalues, _⟩ := hcompatible.layer_reference lay (treeIndexAt index lay) (leafIndexAt index lay)
+      (evalWithAnswerFn context.oracle (layerMessage context.key index lay)) (signature.counter lay) (signature.chainValue lay)
+      (signaturePath signature lay) (context.words_valid hdummy _ _ _) (hfull.1 lay).1 (hfull.1 lay).2
+    have hchain : knownFrontier memory.routing.known context.words lay (treeIndexAt index lay) (leafIndexAt index lay) =
+        signature.chainValue lay := by
+      rw [hfrontier]
+      funext chain
+      exact (hvalues chain).symm
+    simp only [publicSignLayer, referenceSelectionResult, hselected, Option.map_some, hchain, ← hcounter, parts]
+  have hftsPath : knownFtsPath memory.routing.known index leaves = signature.ftsPath := by
+    rw [knownFtsPath_eq context.key.parameter context.key.otsSecret context.key.ftsSecret context.oracle context.words
+      memory.routing.disclosed memory.routing.known hagrees]
+    funext tree level
+    simp only [ftsOpen, evalWithAnswerFn_sequenceFin]
+    exact ((hfull.2.1 tree).2 level.val level.isLt).symm
+  have hauthPath : flattenPaths (fun lay => (parts lay).2.2) = signature.authPath := by
+    funext position
+    obtain ⟨lay, level, hlevel, hposition⟩ := authPath_exhausted position
+    rw [flattenPaths_apply _ lay level hlevel position hposition.symm]
+    change knownTreePath memory.routing.known lay (treeIndexAt index lay) (leafIndexAt index lay) level = signature.authPath position
+    rw [knownTreePath_eq context.key.parameter context.key.otsSecret context.key.ftsSecret context.oracle context.words
+      memory.routing.disclosed memory.routing.known hagrees]
+    simp only [treePath, evalWithAnswerFn_sequenceFin, if_pos hlevel]
+    obtain ⟨_, _, _, hpath⟩ := (hfull.1 lay).1
+    have hpath := hpath 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, honestNode] using hpath.symm
+  simp only [publicSignPlan, hlayers, sequenceFin_some, Option.map_some, hftsPath, PublicSigningPlan.finish, parts]
+  congr 1
+  change Signature.mk signature.randomness (fun tree => context.key.ftsSecret index tree (leaves (ftsIndexOf tree)))
+    signature.ftsPath signature.counter signature.chainValue
+      (flattenPaths fun lay => knownTreePath memory.routing.known lay (treeIndexAt index lay) (leafIndexAt index lay)) = signature
+  have hsecrets : (fun tree => context.key.ftsSecret index tree (leaves (ftsIndexOf tree))) = signature.ftsSecret :=
+    funext fun tree => ((hfull.2.1 tree).1).symm
+  rw [hsecrets, hauthPath]
+
+theorem Compatible.honest_signAfterDigest {inputs : Finset HashInput} {context : Context inputs} {memory : Memory}
+    (hcompatible : Compatible context memory) (hdummy : ∀ lay tree leaf, TargetSum.Valid (context.dummy lay tree leaf))
+    (index : Index) (leaves : IndexGroup → FtsLeaf) (signature : Signature)
+    (hfull : FullyHonestOpening context.oracle memory.external.cache context.key index leaves signature) :
+    evalWithAnswerFn context.oracle (signAfterDigest context.key signature.randomness index leaves) = some signature := by
+  have hwords : context.words = canonicalReferenceWords context.key context.oracle context.dummy :=
+    referencePrefix_words context.key inputs context.encoding context.graph context.auxiliary context.auxiliary_valid context.dummy
+  have hagrees : PublicAgreement (canonicalReferenceWords context.key context.oracle context.dummy)
+      memory.routing.disclosed memory.routing.known
+      (CanonicalCoordinate.value context.key.otsSecret context.key.ftsSecret
+        (canonicalGraphLabels context.key.parameter context.key.otsSecret context.key.ftsSecret context.oracle)) := by
+    rw [← hwords, context.graph_eq]
+    exact hcompatible.agrees
+  have hselection : referenceTableSelection context.key context.oracle = context.auxiliary.selections :=
+    referenceTableSelection_prefix context.key inputs context.encoding context.graph context.auxiliary context.auxiliary_valid
+  rw [← boundaryEval_fst context.key.parameter context.oracle,
+    boundaryEval_signAfterDigest_public context.key context.oracle memory.routing.disclosed memory.routing.known context.dummy hagrees,
+    ← hwords, hselection]
+  exact hcompatible.honest_public_plan hdummy index leaves signature hfull
+
+theorem Compatible.honest_signature_eq {inputs : Finset HashInput} {context : Context inputs} {memory : Memory}
+    (hcompatible : Compatible context memory) (hdummy : ∀ lay tree leaf, TargetSum.Valid (context.dummy lay tree leaf))
+    (index : Index) (leaves : IndexGroup → FtsLeaf) (signature signed : Signature)
+    (hfull : FullyHonestOpening context.oracle memory.external.cache context.key index leaves signature)
+    (hsigned : evalWithAnswerFn context.oracle (signAfterDigest context.key signed.randomness index leaves) = some signed)
+    (hrandomness : signed.randomness = signature.randomness) : signed = signature := by
+  rw [hrandomness, hcompatible.honest_signAfterDigest hdummy index leaves signature hfull] at hsigned
+  exact (Option.some.inj hsigned).symm
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualResources.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualResources.lean
new file mode 100644
index 000000000..0f1ea1859
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualResources.lean
@@ -0,0 +1,143 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualBoundaryCost
+import SphincsSecurity.Proof.Residual.RetainedResidualMonitoredErasure
+import SphincsSecurity.Proof.Residual.RetainedResidualWorkCost
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec ENNReal CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs sourceInputs
+set_option backward.isDefEq.respectTransparency false
+
+def MonitorResources (monitor : CertificateMonitor) (memory : Memory) : Prop :=
+  monitor.spent ≤ memory.external.hashCalls ∧ monitor.creationMass ≤ (memory.external.hashCalls : ENNReal) ∧
+    monitor.messageCalls ≤ memory.messageCalls.length
+
+theorem monitorResources_mono (monitor : CertificateMonitor) (before after : Memory)
+    (h : MonitorResources monitor before) (hhash : before.external.hashCalls ≤ after.external.hashCalls)
+    (hmessage : before.messageCalls.length ≤ after.messageCalls.length) : MonitorResources monitor after :=
+  ⟨h.1.trans hhash, h.2.1.trans (Nat.cast_le.mpr hhash), h.2.2.trans hmessage⟩
+
+theorem monitorResources_update (key : SecretKey) (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+    (input : (OracleWorld + SigningSpec).Domain) {inputs : Finset HashInput} (state : MonitoredState inputs)
+    (length : Nat) (record : ProposalExecutionRecord input) (after : Memory)
+    (hresources : MonitorResources state.2 state.1.memory)
+    (hhash : after.external.hashCalls = state.1.memory.external.hashCalls + record.trace.hashCalls)
+    (hmessage : after.messageCalls = state.1.memory.messageCalls ++ record.trace.messageCalls)
+    (hmass : targetCreationMultiplier key state.1.memory.external.cache input ≤ record.trace.hashCalls) :
+    MonitorResources (certificateMonitorUpdate key budget required stopAfter input (monitorView state) length record) after := by
+  by_cases ha : CertificateMonitorActive key budget input (monitorView state)
+  · rw [certificateMonitorUpdate, if_pos ha]
+    simp only [MonitorResources, monitorView]
+    rw [hhash, hmessage, List.length_append, Nat.cast_add]
+    exact ⟨Nat.add_le_add_right hresources.1 _, add_le_add hresources.2.1 hmass, Nat.add_le_add_right hresources.2.2 _⟩
+  · rw [certificateMonitorUpdate_inactive _ _ _ _ _ _ _ _ ha]
+    change MonitorResources state.2 after
+    apply monitorResources_mono _ _ _ hresources
+    · rw [hhash]; exact Nat.le_add_right _ _
+    · rw [hmessage, List.length_append]; exact Nat.le_add_right _ _
+
+variable (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+  (words : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+  (budget : Nat) (required : Finset FtsTree) (stopAfter : CertificateStopRule)
+
+attribute [local irreducible] lazyRun environment ResidualByteFrontend.jointSigningProgram
+  certificateMonitorUpdate monitorView monitoredSigningResult
+
+theorem monitoredStep_resources (input : (OracleWorld + SigningSpec).Domain)
+    (state : MonitoredState inputs) (hvalid : MonitoredValid inputs state)
+    (hinputs : requestInputs key input ⊆ inputs) (hresources : MonitorResources state.2 state.1.memory)
+    (result : Option ((OracleWorld + SigningSpec).Range input) × MonitoredState inputs)
+    (hresult : monitoredStep key inputs hencoding words publicReplies selections rows budget required stopAfter input state result ≠ 0) :
+    MonitorResources result.2.2 result.2.1.memory := by
+  cases input with
+  | inl input =>
+      rw [monitoredStep, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨raw, hraw, hresult⟩ := hresult
+      simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      rw [lazyRun_externalProgram] at hraw
+      have hh := lazyByteRun_world_hashCalls key.parameter inputs hencoding words publicReplies selections rows state.1.memory.routing
+        input hinputs state.1 hvalid.1 raw hraw
+      have hm := lazyByteRun_world_messageTrace key.parameter inputs hencoding words publicReplies selections rows state.1.memory.routing
+        input hinputs state.1 hvalid.1 raw hraw
+      cases hr : raw.1 with
+      | none =>
+          simp only [monitoredWorldResult, hr, Option.elim_none]
+          change MonitorResources state.2 raw.2.memory
+          apply monitorResources_mono _ _ _ hresources
+          · rw [hh]; exact Nat.le_add_right _ _
+          · rw [hm, hr, Option.elim_none, List.append_nil]
+      | some answer =>
+          simp only [monitoredWorldResult, hr, Option.elim_some]
+          apply monitorResources_update key budget required stopAfter (.inl input) state 0 _ raw.2.memory hresources
+          · change raw.2.memory.external.hashCalls = state.1.memory.external.hashCalls + (signingBoundaryTrace key.parameter input answer).hashCalls
+            rw [signingBoundaryTrace_hashCalls_eq]
+            cases input <;> exact hh
+          · change raw.2.memory.messageCalls = state.1.memory.messageCalls ++ (signingBoundaryTrace key.parameter input answer).messageCalls
+            simpa only [hr, Option.elim_some] using hm
+          · simp only [proposalOfWorldResult, signingBoundaryTrace_hashCalls_eq, targetCreationMultiplier]
+            cases input with
+            | inl sample => exact le_rfl
+            | inr input =>
+                simp only [freshWorldTargetHashCost]
+                split_ifs <;> norm_num
+  | inr message =>
+      rw [monitoredStep, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨annotation, _, hresult⟩ := hresult
+      rw [map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨raw, hraw, hresult⟩ := hresult
+      simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      have hin := digestInputs_of_request key inputs words selections message state.1.memory.routing.known hinputs
+      obtain ⟨record, hr, hm⟩ := lazyRun_jointSigningProgram_memory_trace key.parameter inputs hencoding words publicReplies selections rows
+        state.1.memory.routing key.root message (by simpa only [publicDigestLoop_eq] using hin) state.1 hvalid.1 hvalid.2 raw hraw
+      obtain ⟨other, ho, hmin⟩ := lazyRun_jointSigningProgram_hashCalls_min key inputs hencoding words publicReplies selections rows
+        state.1.memory.routing message hin state.1 hvalid.1 hvalid.2 raw hraw
+      have heq : other = record := Option.some.inj (ho.symm.trans hr)
+      subst other
+      have heq : raw = (some record, raw.2) := Prod.ext hr rfl
+      rw [heq]
+      simp only [monitoredSigningResult]
+      apply monitorResources_update key budget required stopAfter (.inr message) state annotation.1 _
+        (raw.2.memory.recordSigning message record) hresources
+      · rw [hm]; rfl
+      · rw [hm]; rfl
+      · change targetCreationMultiplier key state.1.memory.external.cache (.inr message) ≤ record.2.hashCalls
+        have hp := mul_le_mul' (le_refl (((2 ^ ftsTreeHeight : Nat) : ENNReal)))
+          (freshDigestSelectionProbability_le_one key message state.1.memory.external.cache)
+        calc
+          _ ≤ ((2 ^ ftsTreeHeight : Nat) : ENNReal) := by simpa only [targetCreationMultiplier, mul_one] using hp
+          _ ≤ (28504 : Nat) := by norm_num [ftsTreeHeight]
+          _ ≤ record.2.hashCalls := Nat.cast_le.mpr hmin
+
+theorem monitoredRun_resources {Result : Type} (computation : OracleComp (OracleWorld + SigningSpec) Result)
+    (state : MonitoredState inputs) (hvalid : MonitoredValid inputs state)
+    (hinputs : sourceInputs key computation ⊆ inputs) (hresources : MonitorResources state.2 state.1.memory)
+    (result : Option Result × MonitoredState inputs)
+    (hresult : monitoredRun key inputs hencoding words publicReplies selections rows budget required stopAfter computation state result ≠ 0) :
+    MonitorResources result.2.2 result.2.1.memory := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      rw [monitoredRun_pure] at hresult
+      simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact hresources
+  | query_bind input next ih =>
+      rw [monitoredRun_query_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨⟨answer, after⟩, hstep, hresult⟩ := hresult
+      have hafter := monitoredStep_resources key inputs hencoding words publicReplies selections rows budget required stopAfter
+        input state hvalid ((requestInputs_subset key input next).trans hinputs) hresources (answer, after) hstep
+      cases answer with
+      | none =>
+          simp only [Option.elim_none, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          subst result
+          exact hafter
+      | some answer =>
+          exact ih answer after
+            (monitoredStep_valid key inputs hencoding words publicReplies selections rows budget required stopAfter input state hvalid (some answer, after) hstep)
+            ((sourceInputs_next_subset key input next answer).trans hinputs) hafter result hresult
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualRows.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualRows.lean
new file mode 100644
index 000000000..ba76c6580
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualRows.lean
@@ -0,0 +1,106 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Ots.PrefixEncodingRisk
+import SphincsSecurity.Proof.Residual.RetainedResidualExecution
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs
+set_option backward.isDefEq.respectTransparency false
+
+theorem map_nonzero {A B : Type} (law : SPMF A) (f : A → B) (value : A) (hvalue : law value ≠ 0) :
+    (f <$> law) (f value) ≠ 0 := by
+  rw [map_eq_bind_pure_comp, RetainedObservation.bind_nonzero]
+  exact ⟨value, hvalue, by
+    change (pure (f value) : SPMF B) (f value) ≠ 0
+    rw [SPMF.pure_apply_self]
+    exact one_ne_zero⟩
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+  (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem observedImpl_rowsCovered (actual : Labels) (seed : inputs → HashOutput)
+    (input : (World inputs).Domain) (state : State inputs) (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (result : Option ((World inputs).Range input) × State inputs)
+    (hresult : (observedImpl (environment parameter inputs hencoding words publicReplies selections rows) actual seed input).run.run state result ≠ 0) :
+    ResidualByteFrontend.RowsCovered inputs (project result.2) := by
+  cases input with
+  | inl input =>
+      cases input with
+      | byte routing input =>
+          have hproject := observedRun_embed_query parameter inputs hencoding words publicReplies selections rows routing actual seed (.inl input) state
+          simp only [embed, observedRun, runWith, simulateQ_spec_query] at hproject
+          have h := map_nonzero _ projectResult result hresult
+          rw [hproject] at h
+          exact ResidualByteFrontend.lazyImpl_rowsCovered parameter inputs words routing.disclosed routing.known
+            (ResidualByteAction.freshPrefix parameter inputs hencoding words routing.disclosed routing.known publicReplies selections rows)
+            (.inl input) (project state) hcovered (projectResult result) h
+      | routing =>
+          simp only [observedImpl, environment, OptionT.run_mk, StateT.run_mk, SPMF.lift_pure, pure_bind,
+            ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          subst result
+          exact hcovered
+      | transcript =>
+          simp only [observedImpl, environment, OptionT.run_mk, StateT.run_mk, SPMF.lift_pure, pure_bind,
+            ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          subst result
+          exact hcovered
+      | record message record =>
+          simp only [observedImpl, environment, OptionT.run_mk, StateT.run_mk, SPMF.lift_pure, pure_bind,
+            ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          subst result
+          exact hcovered
+  | inr input =>
+      cases input with
+      | read input =>
+          simp only [observedImpl, OptionT.run_mk, StateT.run_mk, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          subst result
+          simpa only [project, readState, environment, observeMessage_external] using
+            ResidualByteFrontend.rowsCovered_store inputs (project state) hcovered state.candidates input (seed input)
+      | probe input test =>
+          simp only [observedImpl, OptionT.run_mk, StateT.run_mk] at hresult
+          cases hrow : state.rows input with
+          | some answer =>
+              simp only [hrow, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+              subst result
+              simpa only [project, readState, environment, observeMessage_external] using
+                ResidualByteFrontend.rowsCovered_store inputs (project state) hcovered state.candidates input answer
+          | none =>
+              simp only [hrow] at hresult
+              split at hresult
+              all_goals
+                simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+                subst result
+              · simpa only [project, probeState, environment, observeMessage_external] using
+                  ResidualByteFrontend.rowsCovered_store inputs (project state) hcovered (test.restrict state.candidates (seed input)) input (seed input)
+              · exact hcovered
+      | disclose coordinate =>
+          simp only [observedImpl, OptionT.run_mk, StateT.run_mk, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          subst result
+          exact hcovered
+
+theorem observedRun_rowsCovered {Result : Type} (actual : Labels) (seed : inputs → HashOutput)
+    (computation : OracleComp (World inputs) Result) (state : State inputs)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) (result : Option Result × State inputs)
+    (hresult : observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed computation state result ≠ 0) :
+    ResidualByteFrontend.RowsCovered inputs (project result.2) := by
+  induction computation using OracleComp.inductionOn generalizing state result with
+  | pure value =>
+      simp only [observedRun, runWith_pure, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact hcovered
+  | query_bind input next ih =>
+      rw [observedRun, runWith_query_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨⟨answer, after⟩, hafter, hresult⟩ := hresult
+      have hcovered' := observedImpl_rowsCovered parameter inputs hencoding words publicReplies selections rows
+        actual seed input state hcovered (answer, after) hafter
+      cases answer with
+      | none =>
+          simp only [Option.elim_none, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          subst result
+          exact hcovered'
+      | some answer => exact ih answer after hcovered' result hresult
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualSigningCandidates.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualSigningCandidates.lean
new file mode 100644
index 000000000..3671277ff
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualSigningCandidates.lean
@@ -0,0 +1,170 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualCandidates
+import SphincsSecurity.Proof.Residual.RetainedResidualMonitoredErasure
+namespace SphincsSecurity.Concrete.ResidualByteFrontend
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting UniformTableCompletion
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing)
+attribute [local irreducible] hashInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+theorem jointDisclosureSequenceState_candidate {inputs : Finset HashInput}
+    (environment : AdaptiveResidualLabels.Environment (ControlSpec inputs) CanonicalCoordinate inputs ExternalMemory)
+    (actual : Labels) {n : Nat} (coordinates : Fin n → CanonicalCoordinate) (state : State inputs)
+    (coordinate : CanonicalCoordinate) (hne : ∀ index, coordinate ≠ coordinates index) :
+    (jointDisclosureSequenceState environment actual coordinates state).candidates coordinate = state.candidates coordinate := by
+  induction n generalizing state with
+  | zero => rfl
+  | succ n ih =>
+      rw [jointDisclosureSequenceState, List.ofFn_succ, List.foldl_cons]
+      change (jointDisclosureSequenceState environment actual (fun index => coordinates index.succ)
+        (disclosedState environment state (coordinates 0) (actual (coordinates 0)))).candidates coordinate = _
+      rw [ih (coordinates := fun index => coordinates index.succ) (hne := fun index => hne index.succ)]
+      exact Function.update_of_ne (hne 0) _ _
+
+theorem hiddenCandidateBound_disclose {inputs : Finset HashInput} (words : OtsReferenceWords) (routing : Routing)
+    (view : FewTimeView) (secrets : FtsTree → Digest) (state : State inputs)
+    (hbound : HiddenCandidateBound words routing.disclosed state) :
+    HiddenCandidateBound words (routing.disclose view secrets).disclosed state := by
+  intro coordinate hhidden
+  apply hbound coordinate
+  cases coordinate with
+  | otsStart _ _ _ _ => exact hhidden
+  | ftsStart index tree leaf => exact fun h => hhidden (Or.inl h)
+  | graph position =>
+      rw [InterleavedResidual.hidden_graph_disclosed words routing.disclosed (routing.disclose view secrets).disclosed position]
+      exact hhidden
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput) (words : OtsReferenceWords)
+    (routing : Routing) (actions : inputs → ResidualByteAction.Action inputs)
+
+theorem completedWork_hiddenCandidateBound (actual : Labels) (work : PublicSigningRecord × Nat)
+    (state : State inputs) (hbound : HiddenCandidateBound words routing.disclosed state) :
+    HiddenCandidateBound words
+      (routing.afterSigning (completePublicSigningRecord (fun index tree leaf => actual (.ftsStart index tree leaf)) work.1)).disclosed
+      (jointCompletedSigningState (environment parameter inputs words routing.disclosed routing.known actions) actual work.1
+        { state with memory := accountWork state.memory work.2 }) := by
+  obtain ⟨⟨⟨plan, view⟩, trace⟩, cost⟩ := work
+  cases plan <;> cases view <;>
+    simp only [jointCompletedSigningState, completePublicSigningRecord, Option.map_none, Option.map_some, Routing.afterSigning]
+  all_goals try exact hbound
+  rename_i plan view
+  intro coordinate hhidden
+  have hbefore := hiddenCandidateBound_disclose words routing view (fun tree => actual (.ftsStart view.1 tree (view.2 tree))) state hbound
+    coordinate hhidden
+  have hne : ∀ tree, coordinate ≠ .ftsStart view.1 tree (view.2 tree) := by
+    intro tree heq
+    subst coordinate
+    exact hhidden (Or.inr ⟨rfl, rfl⟩)
+  change 2 ^ digestBits ≤ _
+  rw [jointDisclosureSequenceState_candidate _ actual _ _ coordinate hne,
+    jointDisclosureSequenceState_memory]
+  exact hbefore
+
+end SphincsSecurity.Concrete.ResidualByteFrontend
+
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing SigningRecord)
+open ResidualByteFrontend (HiddenCandidateBound)
+attribute [local irreducible] hashInputs sourceInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+  (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem observedRun_completeWork_hiddenCandidateBound (routing : Routing) (actual : Labels) (seed : inputs → HashOutput)
+    (work : PublicSigningRecord × Nat) (state : State inputs)
+    (hbound : HiddenCandidateBound words routing.disclosed (project state))
+    (result : Option SigningRecord × State inputs)
+    (hresult : observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+      (simulateQ (embed inputs routing) (ResidualByteFrontend.jointCompleteSigningWork work)) state result ≠ 0) :
+    ∃ record, result.1 = some record ∧ HiddenCandidateBound words (routing.afterSigning record).disclosed (project result.2) := by
+  have hproject := map_nonzero _ projectResult result hresult
+  rw [observedRun_embed, ResidualByteFrontend.observedRun_jointCompleteSigningWork] at hproject
+  simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hproject
+  refine ⟨completePublicSigningRecord (fun index tree leaf => actual (.ftsStart index tree leaf)) work.1,
+    congrArg Prod.fst hproject, ?_⟩
+  rw [show project result.2 = _ from congrArg Prod.snd hproject]
+  exact ResidualByteFrontend.completedWork_hiddenCandidateBound parameter inputs words routing _ actual work (project state) hbound
+
+theorem lazyRun_completeWork_hiddenCandidateBound (routing : Routing) (work : PublicSigningRecord × Nat) (state : State inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hbound : HiddenCandidateBound words routing.disclosed (project state))
+    (result : Option SigningRecord × State inputs)
+    (hresult : lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+      (simulateQ (embed inputs routing) (ResidualByteFrontend.jointCompleteSigningWork work)) state result ≠ 0) :
+    ∃ record, result.1 = some record ∧ HiddenCandidateBound words (routing.afterSigning record).disclosed (project result.2) := by
+  rw [← run_erasure _ _ state ha, RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨actual, _, hresult⟩ := hresult
+  rw [RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨seed, _, hresult⟩ := hresult
+  exact observedRun_completeWork_hiddenCandidateBound parameter inputs hencoding words publicReplies selections rows routing actual seed
+    work state hbound result hresult
+
+theorem lazyRun_jointSigningProgram_hiddenCandidateBound (routing : Routing) (root : Digest) (message : Message)
+    (hinputs : hashInputs (ResidualByteFrontend.publicSigningWork parameter root routing.known words selections message) ⊆ inputs)
+    (state : State inputs) (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hbound : HiddenCandidateBound words routing.disclosed (project state))
+    (result : Option SigningRecord × State inputs)
+    (hresult : lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+      (simulateQ (embed inputs routing)
+        (ResidualByteFrontend.jointSigningProgram inputs parameter root routing.known words selections message)) state result ≠ 0) :
+    ∃ record, result.1 = some record ∧ HiddenCandidateBound words (routing.afterSigning record).disclosed (project result.2) := by
+  rw [ResidualByteFrontend.jointSigningProgram, simulateQ_bind, lazyRun_bind, RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨middle, hmiddle, hresult⟩ := hresult
+  rw [← lazyByteRun] at hmiddle
+  obtain ⟨⟨work, hwork⟩, hcandidates⟩ := lazyByteRun_message_support parameter inputs hencoding words publicReplies selections rows
+    routing _ hinputs (ResidualByteFrontend.publicSigningWork_messageOnly parameter root routing.known words selections message)
+    state hcovered middle hmiddle
+  have hmiddleBound := lazyByteRun_hiddenCandidateBound parameter inputs hencoding words publicReplies selections rows
+    routing _ hinputs state ha hbound middle hmiddle
+  have hmiddleNonempty : ∀ coordinate, (middle.2.candidates coordinate).Nonempty := by rw [hcandidates]; exact ha
+  rw [hwork, Option.elim_some] at hresult
+  exact lazyRun_completeWork_hiddenCandidateBound parameter inputs hencoding words publicReplies selections rows routing work middle.2
+    hmiddleNonempty hmiddleBound result hresult
+
+theorem lazyRun_embed_routing {Result : Type} (routing : Routing)
+    (computation : OracleComp (ResidualByteFrontend.World inputs) Result) (state : State inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty) (result : Option Result × State inputs)
+    (hresult : lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+      (simulateQ (embed inputs routing) computation) state result ≠ 0) :
+    result.2.memory.routing = state.memory.routing := by
+  rw [← run_erasure _ _ state ha, RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨actual, _, hresult⟩ := hresult
+  rw [RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨seed, _, hresult⟩ := hresult
+  exact congrArg Prod.fst (observedRun_embed_history parameter inputs hencoding words publicReplies selections rows routing actual seed
+    computation state result hresult)
+
+omit parameter hencoding in
+theorem lazyRun_signingProgram_hiddenCandidateBound (key : SecretKey)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (message : Message)
+    (hinputs : hashInputs (signWithView key message) ⊆ inputs) (state : State inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hbound : HiddenCandidateBound words state.memory.routing.disclosed (project state))
+    (result : Option (Option Signature) × State inputs)
+    (hresult : lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+      (signingProgram inputs key.parameter key.root words selections message) state result ≠ 0) :
+    HiddenCandidateBound words result.2.memory.routing.disclosed (project result.2) := by
+  rw [lazyRun_signingProgram key inputs hencoding words publicReplies selections rows message state,
+    map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨raw, hraw, hresult⟩ := hresult
+  have hwork := (ResidualByteFrontend.hashInputs_publicSigningWork_subset_signWithView key state.memory.routing.known words selections message).trans hinputs
+  obtain ⟨record, hrecord, hafter⟩ := lazyRun_jointSigningProgram_hiddenCandidateBound key.parameter inputs hencoding words publicReplies selections rows
+    state.memory.routing key.root message hwork state ha hcovered hbound raw hraw
+  have hrouting := lazyRun_embed_routing key.parameter inputs hencoding words publicReplies selections rows
+    state.memory.routing _ state ha raw hraw
+  simp only [Function.comp_def, hrecord, Option.elim_some, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+  subst result
+  change HiddenCandidateBound words (raw.2.memory.routing.afterSigning record).disclosed (project raw.2)
+  rw [hrouting]
+  exact hafter
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualSigningHistory.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualSigningHistory.lean
new file mode 100644
index 000000000..578c12850
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualSigningHistory.lean
@@ -0,0 +1,207 @@
+import SphincsSecurity.Proof.Residual.RetainedResidualSigningOrigin
+import SphincsSecurity.Proof.Residual.RetainedResidualVerifySupport
+import SphincsSecurity.Proof.Residual.RetainedResidualReplay
+import SphincsSecurity.Proof.Residual.RetainedResidualInitial
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] signDigestLoop signAfterDigest boundaryEval
+set_option backward.isDefEq.respectTransparency false
+
+def signingInput (key : SecretKey) (message : Message) (signature : Signature) : HashInput :=
+  tweakableHashInput key.parameter .message (messageDigestPayload key.root message signature.randomness)
+
+def signingView (key : SecretKey) (oracle : QueryImpl HashSpec Id) (message : Message) (signature : Signature) : FewTimeView :=
+  hashOutputFewTimeView (oracle (signingInput key message signature))
+
+def SignatureOrigin (key : SecretKey) (oracle : QueryImpl HashSpec Id) (cache : ExternalCache)
+    (message : Message) (signature : Signature) : Prop :=
+  let input := signingInput key message signature
+  let digest := truncateMessageDigest (oracle input)
+  cache input ≠ none ∧ Admissible digest ∧
+    evalWithAnswerFn oracle (signAfterDigest key signature.randomness (digestIndex digest) (digestLeaves digest)) = some signature
+
+structure SigningHistory (key : SecretKey) (oracle : QueryImpl HashSpec Id) (memory : Memory) : Prop where
+  entries : ∀ message signature, (⟨message, some signature⟩ : SigningEntry) ∈ memory.log →
+    SignatureOrigin key oracle memory.external.cache message signature
+  disclosed : ∀ index tree leaf, memory.routing.disclosed index tree leaf →
+    ∃ message signature, (⟨message, some signature⟩ : SigningEntry) ∈ memory.log ∧
+      index = (signingView key oracle message signature).1 ∧ leaf = (signingView key oracle message signature).2 tree
+
+private theorem cacheFold_present (entries : List (HashInput × HashOutput)) (cache : ExternalCache)
+    (input : HashInput) (hcache : cache input ≠ none) :
+    (entries.foldl (fun (current : ExternalCache) entry => Function.update current entry.1 (some entry.2)) cache) input ≠ none := by
+  induction entries generalizing cache with
+  | nil => exact hcache
+  | cons entry entries ih =>
+      apply ih
+      change Function.update cache entry.1 (some entry.2) input ≠ none
+      by_cases heq : input = entry.1
+      · subst input
+        rw [Function.update_self]
+        exact Option.some_ne_none _
+      · rw [Function.update_of_ne heq]
+        exact hcache
+
+private theorem cacheFold_entry (entries : List (HashInput × HashOutput)) (cache : ExternalCache)
+    (input : HashInput) (answer : HashOutput) (hentry : (input, answer) ∈ entries) :
+    (entries.foldl (fun (current : ExternalCache) entry => Function.update current entry.1 (some entry.2)) cache) input ≠ none := by
+  induction entries generalizing cache with
+  | nil => cases hentry
+  | cons entry entries ih =>
+      rcases List.mem_cons.mp hentry with heq | hmem
+      · subst entry
+        apply cacheFold_present entries _ input
+        change Function.update cache input (some answer) input ≠ none
+        rw [Function.update_self]
+        exact Option.some_ne_none _
+      · exact ih _ hmem
+
+theorem SignatureOrigin.mono {key : SecretKey} {oracle : QueryImpl HashSpec Id} {before after : ExternalCache}
+    {message : Message} {signature : Signature} (horigin : SignatureOrigin key oracle before message signature)
+    (hcache : ∀ input, before input ≠ none → after input ≠ none) : SignatureOrigin key oracle after message signature :=
+  ⟨hcache _ horigin.1, horigin.2⟩
+
+theorem SigningHistory.transport {key : SecretKey} {oracle : QueryImpl HashSpec Id} {before after : Memory}
+    (hhistory : SigningHistory key oracle before) (hlog : after.log = before.log)
+    (hdisclosed : after.routing.disclosed = before.routing.disclosed)
+    (hcache : ∀ input, before.external.cache input ≠ none → after.external.cache input ≠ none) :
+    SigningHistory key oracle after := by
+  constructor
+  · intro message signature hentry
+    rw [hlog] at hentry
+    exact (hhistory.entries message signature hentry).mono hcache
+  · intro index tree leaf hdisclose
+    rw [hdisclosed] at hdisclose
+    obtain ⟨message, signature, hentry, hcoords⟩ := hhistory.disclosed index tree leaf hdisclose
+    exact ⟨message, signature, hlog ▸ hentry, hcoords⟩
+
+theorem SigningHistory.applyBoundary {key : SecretKey} {oracle : QueryImpl HashSpec Id} {memory : Memory}
+    (hhistory : SigningHistory key oracle memory) (trace : SigningBoundaryTrace) :
+    SigningHistory key oracle (memory.applyBoundary trace) :=
+  hhistory.transport rfl rfl (fun input hcache => cacheFold_present trace.messageCalls _ input hcache)
+
+private theorem disclosed_afterSigning (routing : InterleavedResidual.Routing) (record : SigningRecord)
+    (index : Index) (tree : FtsTree) (leaf : FtsLeaf) (h : (routing.afterSigning record).disclosed index tree leaf) :
+    routing.disclosed index tree leaf ∨ ∃ signature view, record.1.1 = some signature ∧ record.1.2 = some view ∧
+      index = view.1 ∧ leaf = view.2 tree := by
+  rcases record with ⟨⟨signature, view⟩, trace⟩
+  cases signature with
+  | none => exact Or.inl h
+  | some signature =>
+      cases view with
+      | none => exact Or.inl h
+      | some view =>
+          rcases h with hold | hnew
+          · exact Or.inl hold
+          · exact Or.inr ⟨signature, view, rfl, rfl, hnew⟩
+
+theorem SigningHistory.recordSigning {key : SecretKey} {oracle : QueryImpl HashSpec Id} {memory : Memory}
+    (hhistory : SigningHistory key oracle memory) (message : Message) (record : SigningRecord)
+    (hrecord : 𝒟[fixedBoundaryRun key.parameter oracle (signWithView key message)] record ≠ 0) :
+    SigningHistory key oracle ((memory.applyBoundary record.2).recordSigning message record) := by
+  have hbase := hhistory.applyBoundary record.2
+  constructor
+  · intro signedMessage signature hentry
+    change (⟨signedMessage, some signature⟩ : SigningEntry) ∈ memory.log ++ [⟨message, record.1.1⟩] at hentry
+    rcases List.mem_append.mp hentry with hold | hnew
+    · exact hbase.entries signedMessage signature hold
+    · have heq := List.mem_singleton.mp hnew
+      have hmessage : signedMessage = message := congrArg Sigma.fst heq
+      have hsignature : some signature = record.1.1 := congrArg (fun entry : SigningEntry => entry.2) heq
+      subst signedMessage
+      have hrecord' : 𝒟[fixedBoundaryRun key.parameter oracle (signWithView key message)]
+          ((some signature, record.1.2), record.2) ≠ 0 := by
+        simpa only [hsignature] using hrecord
+      obtain ⟨_, hadmissible, hsign, hmem⟩ := fixedBoundaryRun_signing_origin key oracle message signature record.1.2 record.2 hrecord'
+      exact ⟨cacheFold_entry record.2.messageCalls _ _ _ hmem, hadmissible, hsign⟩
+  · intro index tree leaf hdisclose
+    have h := disclosed_afterSigning memory.routing record index tree leaf hdisclose
+    rcases h with hold | ⟨signature, view, hsignature, hview, hcoords⟩
+    · obtain ⟨signedMessage, signature, hentry, hcoords⟩ := hhistory.disclosed index tree leaf hold
+      exact ⟨signedMessage, signature, List.mem_append.mpr (Or.inl hentry), hcoords⟩
+    · have hrecord' : 𝒟[fixedBoundaryRun key.parameter oracle (signWithView key message)]
+          ((some signature, some view), record.2) ≠ 0 := by
+        change 𝒟[fixedBoundaryRun key.parameter oracle (signWithView key message)] ((record.1.1, record.1.2), record.2) ≠ 0 at hrecord
+        simpa only [hsignature, hview] using hrecord
+      have hselected := (fixedBoundaryRun_signing_origin key oracle message signature (some view) record.2 hrecord').1
+      have hselected' : view = signingView key oracle message signature := Option.some.inj hselected
+      refine ⟨message, signature, ?_, ?_⟩
+      · apply List.mem_append.mpr
+        right
+        rw [hsignature]
+        exact List.mem_singleton_self _
+      · simpa only [← hselected'] using hcoords
+
+theorem SigningHistory.fixedHashStep {inputs : Finset HashInput} (context : Context inputs) (input : HashInput)
+    (memory : Memory) (hhistory : SigningHistory context.key context.oracle memory) (answer : HashOutput)
+    (hlive : (fixedHashStep context.key.parameter context.words context.auxiliary.selections memory.routing
+      context.actual context.oracle input memory).1 = some answer) :
+    SigningHistory context.key context.oracle
+      (fixedHashStep context.key.parameter context.words context.auxiliary.selections memory.routing context.actual context.oracle input memory).2 := by
+  apply hhistory.transport (fixedHashStep_log context input memory)
+    (congrArg InterleavedResidual.Routing.disclosed (fixedHashStep_routing ..))
+  intro row hcache
+  rw [fixedHashStep_cache context input memory answer hlive]
+  by_cases heq : row = input
+  · subst row
+    rw [Function.update_self]
+    exact Option.some_ne_none _
+  · rw [Function.update_of_ne heq]
+    exact hcache
+
+theorem fixedSourceImpl_signingHistory {inputs : Finset HashInput} (context : Context inputs)
+    (input : (OracleWorld + SigningSpec).Domain) (memory : Memory) (hhistory : SigningHistory context.key context.oracle memory)
+    (answer : (OracleWorld + SigningSpec).Range input) (after : Memory)
+    (hresult : (fixedSourceImpl context input).run.run memory (some answer, after) ≠ 0) :
+    SigningHistory context.key context.oracle after := by
+  cases input with
+  | inl input =>
+      simp only [fixedSourceImpl, OptionT.run_mk, StateT.run_mk, fixedByteRun, simulateQ_spec_query] at hresult
+      cases input with
+      | inl input =>
+          simp only [fixedByteImpl, OptionT.run_mk, StateT.run_mk, RetainedObservation.bind_nonzero] at hresult
+          obtain ⟨value, _, hresult⟩ := hresult
+          simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not, Prod.mk.injEq] at hresult
+          exact hresult.2 ▸ hhistory
+      | inr input =>
+          simp only [fixedByteImpl, OptionT.run_mk, StateT.run_mk, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          have h := hhistory.fixedHashStep context input memory answer (congrArg Prod.fst hresult).symm
+          simpa only [← hresult] using h
+  | inr message =>
+      simp only [fixedSourceImpl, OptionT.run_mk, StateT.run_mk, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨record, hrecord, hresult⟩ := hresult
+      simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not, Prod.mk.injEq] at hresult
+      exact hresult.2 ▸ hhistory.recordSigning message record hrecord
+
+theorem fixedSourceRun_signingHistory {Result : Type} {inputs : Finset HashInput} (context : Context inputs)
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) (memory : Memory)
+    (hhistory : SigningHistory context.key context.oracle memory) (value : Result) (after : Memory)
+    (hresult : fixedSourceRun context computation memory (some value, after) ≠ 0) :
+    SigningHistory context.key context.oracle after := by
+  induction computation using OracleComp.inductionOn generalizing memory value after with
+  | pure value =>
+      simp only [fixedSourceRun_pure, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not, Prod.mk.injEq] at hresult
+      exact hresult.2 ▸ hhistory
+  | query_bind input next ih =>
+      rw [fixedSourceRun_query_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨⟨answer, middle⟩, hmiddle, hresult⟩ := hresult
+      cases answer with
+      | none =>
+          simp only [Option.elim_none, ne_eq, SPMF.pure_apply_eq_zero_iff, Prod.mk.injEq, Option.some_ne_none, false_and, not_not] at hresult
+      | some answer =>
+          exact ih answer middle (fixedSourceImpl_signingHistory context input memory hhistory answer middle hmiddle) value after hresult
+
+theorem signingHistory_initial (key : SecretKey) (oracle : QueryImpl HashSpec Id)
+    (words : OtsReferenceWords) (exposed : InitialPublicLabels words) :
+    SigningHistory key oracle (initialMemory words exposed) := by
+  constructor
+  · intro message signature hentry
+    cases hentry
+  · intro index tree leaf hdisclose
+    cases hdisclose
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualSigningKernel.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualSigningKernel.lean
new file mode 100644
index 000000000..5a0d42d4c
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualSigningKernel.lean
@@ -0,0 +1,97 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.DigestSelectionWeight
+import SphincsSecurity.Proof.Residual.RetainedResidualCompletion
+import SphincsSecurity.Proof.Residual.RetainedResidualDigestLaw
+import SphincsSecurity.Proof.Residual.RetainedResidualRows
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs publicSignPlan
+set_option backward.isDefEq.respectTransparency false
+
+def digestWork (known : Labels) (words : OtsReferenceWords) (selections : ReferenceFamily)
+    (selected : Option (Randomness × Index × (IndexGroup → FtsLeaf)) × SigningBoundaryTrace) : PublicSigningRecord × Nat :=
+  match selected.1 with
+  | none => (((none, none), selected.2), 0)
+  | some (randomness, index, leaves) =>
+      let plan := publicSignPlan known words selections randomness index leaves
+      (((plan.1, some (selectedFewTimeView index leaves)), selected.2 * (FreeMonoid.of none) ^ plan.2), plan.2)
+
+theorem publicSigningWork_eq_digestWork (parameter : PublicParameter) (root : Digest) (known : Labels)
+    (words : OtsReferenceWords) (selections : ReferenceFamily) (message : Message) :
+    ResidualByteFrontend.publicSigningWork parameter root known words selections message =
+      digestWork known words selections <$> boundaryComputation parameter (publicDigestLoop parameter root message digestAttemptLimit) := by
+  rw [ResidualByteFrontend.publicSigningWork, map_eq_bind_pure_comp]
+  apply bind_congr
+  rintro ⟨selected, trace⟩
+  cases selected <;> rfl
+
+theorem completePublicSigningRecord_digestWork_consistent (known : Labels) (words : OtsReferenceWords)
+    (selections : ReferenceFamily) (ftsSecret : Index → FtsTree → FtsLeaf → Digest)
+    (loop : DigestLoopRecord) (trace : SigningBoundaryTrace) :
+    DigestCompletionConsistent loop
+      ((completePublicSigningRecord ftsSecret (digestWork known words selections (loop.1, trace)).1).1, loop.2) := by
+  rcases loop with ⟨selected, cache⟩
+  cases selected with
+  | none => simp [DigestCompletionConsistent, digestWork, completePublicSigningRecord, selectedLoopView?]
+  | some selected =>
+      obtain ⟨randomness, index, leaves⟩ := selected
+      constructor
+      · rfl
+      · intro signature hs
+        simp only [digestWork, completePublicSigningRecord, Option.map_eq_some_iff] at hs
+        obtain ⟨plan, hplan, rfl⟩ := hs
+        have hr : plan.randomness = randomness := by
+          unfold publicSignPlan at hplan
+          obtain ⟨parts, _, rfl⟩ := Option.map_eq_some_iff.mp hplan
+          rfl
+        exact ⟨index, leaves, by simp only [PublicSigningPlan.finish, hr]⟩
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+  (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem lazyRun_completeWork_memory (routing : Routing) (work : PublicSigningRecord × Nat) (state : State inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty) :
+    forgetState <$> lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+      (simulateQ (embed inputs routing) (ResidualByteFrontend.jointCompleteSigningWork work)) state =
+      (UniformTableCompletion.complete state.candidates >>= fun actual =>
+        pure (some (completePublicSigningRecord (fun index tree leaf => actual (.ftsStart index tree leaf)) work.1),
+          state.memory.accountWork work.2)) := by
+  rw [← run_erasure _ _ state ha]
+  simp only [map_bind, observedRun_completeWork_memory parameter inputs hencoding words publicReplies selections rows routing,
+    ResidualTableCompletion.completeRows_bind_const]
+
+theorem lazyRun_completeWork_cache (routing : Routing) (work : PublicSigningRecord × Nat) (state : State inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty) :
+    cacheResult <$> lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+      (simulateQ (embed inputs routing) (ResidualByteFrontend.jointCompleteSigningWork work)) state =
+      (UniformTableCompletion.complete state.candidates >>= fun actual =>
+        pure (some (completePublicSigningRecord (fun index tree leaf => actual (.ftsStart index tree leaf)) work.1),
+          state.memory.external.cache)) := by
+  have h := congrArg (fun law : SPMF (Option SigningRecord × Memory) =>
+    (fun result => (result.1, result.2.external.cache)) <$> law)
+      (lazyRun_completeWork_memory parameter inputs hencoding words publicReplies selections rows routing work state ha)
+  unfold cacheResult
+  simpa only [Functor.map_map, Function.comp_def, forgetState, cacheResult, map_bind, map_pure,
+    Memory.accountWork, ResidualByteFrontend.accountWork] using h
+
+theorem lazyRun_completeWork_support (routing : Routing) (work : PublicSigningRecord × Nat) (state : State inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty) (result : Option SigningRecord × State inputs)
+    (hresult : lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+      (simulateQ (embed inputs routing) (ResidualByteFrontend.jointCompleteSigningWork work)) state result ≠ 0) :
+    ∃ actual : Labels,
+      result.1 = some (completePublicSigningRecord (fun index tree leaf => actual (.ftsStart index tree leaf)) work.1) ∧
+      result.2.memory = state.memory.accountWork work.2 := by
+  have hmap : (forgetState <$> lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+      (simulateQ (embed inputs routing) (ResidualByteFrontend.jointCompleteSigningWork work)) state) (forgetState result) ≠ 0 :=
+    map_nonzero _ forgetState result hresult
+  rw [lazyRun_completeWork_memory parameter inputs hencoding words publicReplies selections rows routing work state ha] at hmap
+  obtain ⟨actual, _, hfinish⟩ := (RetainedObservation.bind_nonzero _ _ _).mp hmap
+  simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hfinish
+  exact ⟨actual, congrArg Prod.fst hfinish, congrArg Prod.snd hfinish⟩
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualSigningLaw.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualSigningLaw.lean
new file mode 100644
index 000000000..fcf9677b3
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualSigningLaw.lean
@@ -0,0 +1,127 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.DigestSigningCompletion
+import SphincsSecurity.Proof.Residual.ResidualSigningProgram
+import SphincsSecurity.Proof.Residual.RetainedResidualSigningKernel
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs
+set_option backward.isDefEq.respectTransparency false
+
+def completeWorkCache (actual : Labels) (result : Option (PublicSigningRecord × Nat) × QueryCache HashSpec) :
+    Option SigningRecord × QueryCache HashSpec :=
+  (result.1.map (fun work => completePublicSigningRecord (fun index tree leaf => actual (.ftsStart index tree leaf)) work.1), result.2)
+
+def eraseSigningTrace (result : Option SigningRecord × QueryCache HashSpec) :
+    Option (Option Signature × Option FewTimeView) × QueryCache HashSpec := (result.1.map Prod.fst, result.2)
+
+def digestCompletionValue (known : Labels) (words : OtsReferenceWords) (selections : ReferenceFamily)
+    (actual : Labels) (loop : DigestLoopRecord) : (Option Signature × Option FewTimeView) × QueryCache HashSpec :=
+  ((completePublicSigningRecord (fun index tree leaf => actual (.ftsStart index tree leaf))
+    (digestWork known words selections (loop.1, 1)).1).1, loop.2)
+
+theorem digestCompletionValue_preservesMessages (key : SecretKey) (known : Labels) (words : OtsReferenceWords)
+    (selections : ReferenceFamily) (actual : Labels) (loop : DigestLoopRecord) :
+    DigestCompletionPreservesMessages key loop (digestCompletionValue known words selections actual loop) :=
+  ⟨completePublicSigningRecord_digestWork_consistent known words selections _ loop 1, rfl⟩
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+  (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem lazyRun_jointSigningProgram_cache (routing : Routing) (root : Digest) (message : Message)
+    (hinputs : hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs) (state : State inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) :
+    cacheResult <$> lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+      (simulateQ (embed inputs routing)
+        (ResidualByteFrontend.jointSigningProgram inputs parameter root routing.known words selections message)) state =
+      (UniformTableCompletion.complete state.candidates >>= fun actual =>
+        (fun result => (some (completePublicSigningRecord (fun index tree leaf => actual (.ftsStart index tree leaf)) result.1.1), result.2)) <$>
+          𝒟[(simulateQ romImpl (ResidualByteFrontend.publicSigningWork parameter root routing.known words selections message)).run
+            state.memory.external.cache]) := by
+  let work := ResidualByteFrontend.publicSigningWork parameter root routing.known words selections message
+  have hwork : hashInputs work ⊆ inputs := by
+    simpa only [work, ResidualByteFrontend.hashInputs_publicSigningWork] using hinputs
+  have hmwork := ResidualByteFrontend.publicSigningWork_messageOnly parameter root routing.known words selections message
+  rw [ResidualByteFrontend.jointSigningProgram, simulateQ_bind, lazyRun_bind, map_bind]
+  change (lazyByteRun parameter inputs hencoding words publicReplies selections rows routing work state >>= fun result =>
+    cacheResult <$> result.1.elim (pure (none, result.2)) (fun value =>
+      lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+        (simulateQ (embed inputs routing) (ResidualByteFrontend.jointCompleteSigningWork value)) result.2)) = _
+  calc
+    _ = lazyByteRun parameter inputs hencoding words publicReplies selections rows routing work state >>= fun result =>
+        UniformTableCompletion.complete state.candidates >>= fun actual => pure (completeWorkCache actual (cacheResult result)) := by
+      apply RetainedObservation.bind_congr
+      intro result hresult
+      obtain ⟨⟨value, hvalue⟩, hcandidates⟩ := lazyByteRun_message_support parameter inputs hencoding words publicReplies selections rows
+        routing work hwork hmwork state hcovered result hresult
+      have ha' : ∀ coordinate, (result.2.candidates coordinate).Nonempty := by rw [hcandidates]; exact ha
+      rw [hvalue, Option.elim_some, lazyRun_completeWork_cache parameter inputs hencoding words publicReplies selections rows routing value result.2 ha',
+        hcandidates]
+      simp only [completeWorkCache, cacheResult, hvalue, Option.map_some]
+    _ = UniformTableCompletion.complete state.candidates >>= fun actual =>
+        completeWorkCache actual <$> (cacheResult <$>
+          lazyByteRun parameter inputs hencoding words publicReplies selections rows routing work state) := by
+      rw [RetainedObservation.bind_comm]
+      simp only [map_eq_bind_pure_comp, Function.comp_def, bind_assoc, pure_bind]
+    _ = _ := by
+      rw [lazyByteRun_message_rom parameter inputs hencoding words publicReplies selections rows routing work hwork hmwork state hcovered]
+      apply congrArg (fun next : Labels → SPMF (Option SigningRecord × QueryCache HashSpec) =>
+        UniformTableCompletion.complete state.candidates >>= next)
+      funext actual
+      rw [Functor.map_map]
+      congr 1
+
+theorem lazyRun_jointSigningProgram_digestLaw (routing : Routing) (key : SecretKey) (hparameter : key.parameter = parameter)
+    (message : Message) (hinputs : hashInputs (signDigestLoop digestAttemptLimit key message) ⊆ inputs) (state : State inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) :
+    eraseSigningTrace <$> (cacheResult <$> lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+      (simulateQ (embed inputs routing)
+        (ResidualByteFrontend.jointSigningProgram inputs parameter key.root routing.known words selections message)) state) =
+      (UniformTableCompletion.complete state.candidates >>= fun actual =>
+        Prod.map some id <$> 𝒟[digestCompletionValue routing.known words selections actual <$>
+          (simulateQ romImpl (signDigestLoop digestAttemptLimit key message)).run state.memory.external.cache]) := by
+  have hloop : publicDigestLoop parameter key.root message digestAttemptLimit = signDigestLoop digestAttemptLimit key message := by
+    rw [← hparameter, publicDigestLoop_eq]
+  have hin : hashInputs (publicDigestLoop parameter key.root message digestAttemptLimit) ⊆ inputs := by rwa [hloop]
+  rw [lazyRun_jointSigningProgram_cache parameter inputs hencoding words publicReplies selections rows routing key.root message hin state ha hcovered,
+    map_bind]
+  apply congrArg (fun next : Labels → SPMF (Option (Option Signature × Option FewTimeView) × QueryCache HashSpec) =>
+    UniformTableCompletion.complete state.candidates >>= next)
+  funext actual
+  rw [publicSigningWork_eq_digestWork, simulateQ_map, StateT.run_map, evalDist_map, Functor.map_map,
+    Functor.map_map, hloop, simulateQ_boundaryComputation]
+  rw [← boundaryRun_forget parameter (signDigestLoop digestAttemptLimit key message) state.memory.external.cache,
+    evalDist_map, evalDist_map, Functor.map_map, Functor.map_map]
+  change (fun result => eraseSigningTrace
+    (some (completePublicSigningRecord (fun index tree leaf => actual (.ftsStart index tree leaf))
+      (digestWork routing.known words selections result.1).1), result.2)) <$>
+      𝒟[boundaryRun parameter (signDigestLoop digestAttemptLimit key message) state.memory.external.cache] = _
+  congr 1
+  funext result
+  rcases result with ⟨⟨selected, trace⟩, cache⟩
+  cases selected <;> rfl
+
+theorem lazyRun_jointSigningProgram_some (routing : Routing) (root : Digest) (message : Message)
+    (hinputs : hashInputs (publicDigestLoop parameter root message digestAttemptLimit) ⊆ inputs) (state : State inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) (result : Option SigningRecord × State inputs)
+    (hresult : lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+      (simulateQ (embed inputs routing)
+        (ResidualByteFrontend.jointSigningProgram inputs parameter root routing.known words selections message)) state result ≠ 0) :
+    ∃ record, result.1 = some record := by
+  have h := map_nonzero _ cacheResult result hresult
+  rw [lazyRun_jointSigningProgram_cache parameter inputs hencoding words publicReplies selections rows routing root message
+    hinputs state ha hcovered, RetainedObservation.bind_nonzero] at h
+  obtain ⟨actual, _, h⟩ := h
+  rw [map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at h
+  obtain ⟨work, _, h⟩ := h
+  simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at h
+  exact ⟨_, congrArg Prod.fst h⟩
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualSigningOrigin.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualSigningOrigin.lean
new file mode 100644
index 000000000..8b88aea99
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualSigningOrigin.lean
@@ -0,0 +1,203 @@
+import SphincsSecurity.Proof.Reference.FixedHashBoundary
+import SphincsSecurity.Proof.Residual.RetainedObservation
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] signDigestLoop signAfterDigest boundaryEval
+set_option backward.isDefEq.respectTransparency false
+
+theorem fixedBoundaryRun_bind_nonzero {A B : Type} (parameter : PublicParameter) (oracle : QueryImpl HashSpec Id)
+    (first : OracleComp OracleWorld A) (next : A → OracleComp OracleWorld B) (result : B × SigningBoundaryTrace)
+    (hresult : 𝒟[fixedBoundaryRun parameter oracle (first >>= next)] result ≠ 0) :
+    ∃ before after, 𝒟[fixedBoundaryRun parameter oracle first] before ≠ 0 ∧
+      𝒟[fixedBoundaryRun parameter oracle (next before.1)] after ≠ 0 ∧ result = (after.1, before.2 * after.2) := by
+  rw [fixedBoundaryRun_bind, evalDist_bind, RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨before, hbefore, hresult⟩ := hresult
+  rw [evalDist_map, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨after, hafter, hresult⟩ := hresult
+  simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+  exact ⟨before, after, hbefore, hafter, hresult⟩
+
+private theorem fixedBoundaryRun_lift_hash_return {A B : Type} (parameter : PublicParameter) (oracle : QueryImpl HashSpec Id)
+    (computation : OracleComp HashSpec A) (finish : A → B) :
+    fixedBoundaryRun parameter oracle ((liftM computation : OracleComp OracleWorld A) >>= fun value => pure (finish value)) =
+      pure (finish (evalWithAnswerFn oracle computation), (boundaryEval parameter oracle computation).2) := by
+  rw [fixedBoundaryRun_bind, fixedBoundaryRun_lift_hash, pure_bind, fixedBoundaryRun_pure, map_pure, mul_one, boundaryEval_fst]
+
+theorem boundaryEval_signAttempt (key : SecretKey) (oracle : QueryImpl HashSpec Id)
+    (message : Message) (randomness : Randomness) :
+    boundaryEval key.parameter oracle (signAttempt key message randomness) =
+      (signAttemptResultOfOutput (oracle (tweakableHashInput key.parameter .message
+        (messageDigestPayload key.root message randomness))),
+        FreeMonoid.of (some (tweakableHashInput key.parameter .message (messageDigestPayload key.root message randomness),
+          oracle (tweakableHashInput key.parameter .message (messageDigestPayload key.root message randomness))))) := by
+  have hquery (input : HashInput) :
+      evalWithAnswerFn oracle (liftM (HashSpec.query input) : OracleComp HashSpec HashOutput) = oracle input := rfl
+  by_cases h : Admissible (truncateMessageDigest (oracle (tweakableHashInput key.parameter .message
+    (messageDigestPayload key.root message randomness))))
+  all_goals simp [signAttempt, messageDigest, oracleHash, boundaryEval_bind, boundaryEval_hash_query,
+    hquery, boundaryEval_pure, signAttemptResultOfOutput, signingBoundaryTrace,
+    FtsProbeSimulation.MessageHashInput, h]
+
+private theorem signDigestLoop_succ (key : SecretKey) (message : Message) (attempts : Nat) :
+    signDigestLoop (attempts + 1) key message = (do
+      let randomness ← liftM sampleRandomness
+      let attempt ← liftM (signAttempt key message randomness : OracleComp HashSpec _)
+      match attempt with
+      | some (index, leaves) => pure (some (randomness, index, leaves))
+      | none => signDigestLoop attempts key message) := by
+  rw [signDigestLoop]
+  apply bind_congr
+  intro randomness
+  apply bind_congr
+  intro attempt
+  cases attempt with
+  | none => rfl
+  | some selected => rcases selected with ⟨index, leaves⟩; rfl
+
+private noncomputable def finishSelected (key : SecretKey) :
+    Option (Randomness × Index × (IndexGroup → FtsLeaf)) → OracleComp OracleWorld (Option Signature × Option FewTimeView)
+  | none => pure (none, none)
+  | some (randomness, index, leaves) => do
+      let signature ← liftM (signAfterDigest key randomness index leaves)
+      pure (signature, some (selectedFewTimeView index leaves))
+
+private theorem signWithView_bind (key : SecretKey) (message : Message) :
+    signWithView key message = signDigestLoop digestAttemptLimit key message >>= finishSelected key := by
+  rw [signWithView]
+  apply bind_congr
+  intro selected
+  cases selected with
+  | none => rfl
+  | some selected => rcases selected with ⟨randomness, index, leaves⟩; rfl
+
+theorem fixedBoundaryRun_digest_selected (key : SecretKey) (oracle : QueryImpl HashSpec Id) (message : Message)
+    (attempts : Nat) (randomness : Randomness) (index : Index) (leaves : IndexGroup → FtsLeaf)
+    (trace : SigningBoundaryTrace)
+    (hresult : 𝒟[fixedBoundaryRun key.parameter oracle (signDigestLoop attempts key message)]
+      (some (randomness, index, leaves), trace) ≠ 0) :
+    let input := tweakableHashInput key.parameter .message (messageDigestPayload key.root message randomness)
+    signAttemptResultOfOutput (oracle input) = some (index, leaves) ∧ (input, oracle input) ∈ trace.messageCalls := by
+  induction attempts generalizing randomness index leaves trace with
+  | zero =>
+      simp only [signDigestLoop, fixedBoundaryRun_pure, evalDist_pure, ne_eq,
+        SPMF.pure_apply_eq_zero_iff, Prod.mk.injEq, Option.some_ne_none, false_and, not_not] at hresult
+  | succ attempts ih =>
+      rw [signDigestLoop_succ] at hresult
+      obtain ⟨⟨sampled, sampledTrace⟩, ⟨result, restTrace⟩, _, hrest, heq⟩ :=
+        fixedBoundaryRun_bind_nonzero key.parameter oracle _ _ _ hresult
+      obtain ⟨⟨attempt, attemptTrace⟩, ⟨finished, finishTrace⟩, hattempt, hfinish, heq'⟩ :=
+        fixedBoundaryRun_bind_nonzero key.parameter oracle _ _ _ hrest
+      have htrace : trace = sampledTrace * (attemptTrace * finishTrace) :=
+        (Prod.mk.inj heq).2.trans (congrArg (sampledTrace * ·) (Prod.mk.inj heq').2)
+      have hvalue : some (randomness, index, leaves) = finished :=
+        (Prod.mk.inj heq).1.trans (Prod.mk.inj heq').1
+      cases attempt with
+      | none =>
+          rw [← hvalue] at hfinish
+          obtain ⟨hselected, hmem⟩ := ih randomness index leaves finishTrace hfinish
+          refine ⟨hselected, ?_⟩
+          rw [htrace, SigningBoundaryTrace.messageCalls_mul, List.mem_append]
+          exact Or.inr (by rw [SigningBoundaryTrace.messageCalls_mul, List.mem_append]; exact Or.inr hmem)
+      | some selected =>
+          rcases selected with ⟨selectedIndex, selectedLeaves⟩
+          have hfinish' : (finished, finishTrace) = (some (sampled, selectedIndex, selectedLeaves), 1) := by
+            simpa only [fixedBoundaryRun_pure, evalDist_pure, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] using hfinish
+          have hselected : (some (selectedIndex, selectedLeaves), attemptTrace) =
+              boundaryEval key.parameter oracle (signAttempt key message sampled) := by
+            simpa only [fixedBoundaryRun_lift_hash, evalDist_pure, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] using hattempt
+          rw [boundaryEval_signAttempt] at hselected
+          have hmem : (tweakableHashInput key.parameter .message (messageDigestPayload key.root message sampled),
+              oracle (tweakableHashInput key.parameter .message (messageDigestPayload key.root message sampled))) ∈ trace.messageCalls := by
+            rw [htrace, SigningBoundaryTrace.messageCalls_mul, List.mem_append]
+            refine Or.inr ?_
+            rw [SigningBoundaryTrace.messageCalls_mul, List.mem_append]
+            refine Or.inl ?_
+            rw [(Prod.mk.inj hselected).2]
+            exact List.mem_singleton_self _
+          have hvalues : (randomness, index, leaves) = (sampled, selectedIndex, selectedLeaves) :=
+            Option.some.inj (hvalue.trans (Prod.mk.inj hfinish').1)
+          dsimp only
+          rw [(Prod.mk.inj hvalues).1, (Prod.mk.inj (Prod.mk.inj hvalues).2).1,
+            (Prod.mk.inj (Prod.mk.inj hvalues).2).2]
+          exact ⟨(Prod.mk.inj hselected).1.symm, hmem⟩
+
+private theorem finish_none_support (key : SecretKey) (oracle : QueryImpl HashSpec Id)
+    (result : (Option Signature × Option FewTimeView) × SigningBoundaryTrace)
+    (h : 𝒟[fixedBoundaryRun key.parameter oracle (finishSelected key none)] result ≠ 0) : result = ((none, none), 1) := by
+  simpa only [finishSelected, fixedBoundaryRun_pure, evalDist_pure, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] using h
+
+private theorem finish_some_support (key : SecretKey) (oracle : QueryImpl HashSpec Id)
+    (randomness : Randomness) (index : Index) (leaves : IndexGroup → FtsLeaf)
+    (result : (Option Signature × Option FewTimeView) × SigningBoundaryTrace)
+    (h : 𝒟[fixedBoundaryRun key.parameter oracle (finishSelected key (some (randomness, index, leaves)))] result ≠ 0) :
+    result = ((evalWithAnswerFn oracle (signAfterDigest key randomness index leaves), some (selectedFewTimeView index leaves)),
+      (boundaryEval key.parameter oracle (signAfterDigest key randomness index leaves)).2) := by
+  simpa only [finishSelected, fixedBoundaryRun_lift_hash_return, evalDist_pure, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] using h
+
+private theorem finish_success (key : SecretKey) (oracle : QueryImpl HashSpec Id)
+    (selected : Option (Randomness × Index × (IndexGroup → FtsLeaf)))
+    (signature : Signature) (view : Option FewTimeView) (trace : SigningBoundaryTrace)
+    (h : 𝒟[fixedBoundaryRun key.parameter oracle (finishSelected key selected)] ((some signature, view), trace) ≠ 0) :
+    ∃ randomness index leaves, selected = some (randomness, index, leaves) ∧
+      evalWithAnswerFn oracle (signAfterDigest key randomness index leaves) = some signature ∧
+      view = some (selectedFewTimeView index leaves) := by
+  cases selected with
+  | none =>
+      have heq := finish_none_support key oracle _ h
+      have hnone : some signature = none := (Prod.mk.inj (Prod.mk.inj heq).1).1
+      cases hnone
+  | some selected =>
+      rcases selected with ⟨randomness, index, leaves⟩
+      have heq := finish_some_support key oracle randomness index leaves _ h
+      exact ⟨randomness, index, leaves, rfl, (Prod.mk.inj (Prod.mk.inj heq).1).1.symm,
+        (Prod.mk.inj (Prod.mk.inj heq).1).2⟩
+
+private theorem fixedBoundaryRun_signing_selected (key : SecretKey) (oracle : QueryImpl HashSpec Id)
+    (loop : OracleComp OracleWorld (Option (Randomness × Index × (IndexGroup → FtsLeaf))))
+    (signature : Signature) (view : Option FewTimeView) (trace : SigningBoundaryTrace)
+    (hresult : 𝒟[fixedBoundaryRun key.parameter oracle (loop >>= finishSelected key)] ((some signature, view), trace) ≠ 0) :
+    ∃ randomness index leaves loopTrace tailTrace,
+      𝒟[fixedBoundaryRun key.parameter oracle loop]
+        (some (randomness, index, leaves), loopTrace) ≠ 0 ∧
+      evalWithAnswerFn oracle (signAfterDigest key randomness index leaves) = some signature ∧
+      view = some (selectedFewTimeView index leaves) ∧ trace = loopTrace * tailTrace := by
+  obtain ⟨⟨selected, loopTrace⟩, ⟨result, tailTrace⟩, hloop, htail, heq⟩ :=
+    fixedBoundaryRun_bind_nonzero key.parameter oracle loop (finishSelected key) _ hresult
+  have hreturn : (some signature, view) = result := (Prod.mk.inj heq).1
+  rw [← hreturn] at htail
+  obtain ⟨randomness, index, leaves, hselected, hsign, hview⟩ := finish_success key oracle selected signature view tailTrace htail
+  rw [hselected] at hloop
+  exact ⟨randomness, index, leaves, loopTrace, tailTrace, hloop, hsign, hview, (Prod.mk.inj heq).2⟩
+
+theorem fixedBoundaryRun_signing_origin (key : SecretKey) (oracle : QueryImpl HashSpec Id)
+    (message : Message) (signature : Signature) (view : Option FewTimeView) (trace : SigningBoundaryTrace)
+    (hresult : 𝒟[fixedBoundaryRun key.parameter oracle (signWithView key message)] ((some signature, view), trace) ≠ 0) :
+    let input := tweakableHashInput key.parameter .message (messageDigestPayload key.root message signature.randomness)
+    let digest := truncateMessageDigest (oracle input)
+    view = some (hashOutputFewTimeView (oracle input)) ∧ Admissible digest ∧
+      evalWithAnswerFn oracle (signAfterDigest key signature.randomness (digestIndex digest) (digestLeaves digest)) = some signature ∧
+      (input, oracle input) ∈ trace.messageCalls := by
+  rw [signWithView_bind] at hresult
+  obtain ⟨randomness, index, leaves, loopTrace, tailTrace, hloop, hsign, hview, htrace⟩ :=
+    fixedBoundaryRun_signing_selected key oracle (signDigestLoop digestAttemptLimit key message) signature view trace hresult
+  have hrandomness := signAfterDigest_some_randomness oracle key randomness index leaves signature hsign
+  obtain ⟨hselected, hmem⟩ := fixedBoundaryRun_digest_selected key oracle message digestAttemptLimit randomness index leaves loopTrace hloop
+  dsimp only
+  rw [hrandomness]
+  dsimp only [signAttemptResultOfOutput] at hselected
+  split at hselected
+  next hadmissible =>
+    have hcoords := Prod.mk.inj (Option.some.inj hselected)
+    refine ⟨?_, hadmissible, ?_, ?_⟩
+    · change view = some (selectedFewTimeView _ _)
+      rw [hcoords.1, hcoords.2]
+      exact hview
+    · rw [hcoords.1, hcoords.2]
+      exact hsign
+    · rw [htrace, SigningBoundaryTrace.messageCalls_mul, List.mem_append]
+      exact Or.inl hmem
+  next hadmissible => cases hselected
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualSigningTrace.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualSigningTrace.lean
new file mode 100644
index 000000000..cc442d85c
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualSigningTrace.lean
@@ -0,0 +1,174 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualCompletion
+import SphincsSecurity.Proof.Residual.RetainedResidualProgram
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs
+set_option backward.isDefEq.respectTransparency false
+
+def finishWork (actual : Labels) (result : Option (PublicSigningRecord × Nat) × Memory) : Option SigningRecord × Memory :=
+  result.1.elim (none, result.2) (fun work =>
+    (some (completePublicSigningRecord (fun index tree leaf => actual (.ftsStart index tree leaf)) work.1), result.2.accountWork work.2))
+
+theorem observedRun_externalProgram_original_memory {Result : Type} (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+    (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+    (otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest)
+    (ftsSecret : Index → FtsTree → FtsLeaf → Digest) (graph : CanonicalGraphLabels)
+    (seed : inputs → HashOutput) (computation : OracleComp OracleWorld Result)
+    (hinputs : hashInputs computation ⊆ inputs) (state : State inputs)
+    (hagrees : PublicAgreement words state.memory.routing.disclosed state.memory.routing.known
+      (CanonicalCoordinate.value otsSecret ftsSecret graph))
+    (hreplies : ∀ position, ¬CanonicalCoordinate.Hidden words state.memory.routing.disclosed (.graph position) → publicReplies position = graph position)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hmatches : ResidualByteFrontend.CacheMatches (programmedHash parameter otsSecret ftsSecret graph
+      (finiteHashAnswer ∅ inputs (canonicalPrefixResidual parameter inputs hencoding graph selections rows seed))) state.memory.external.cache)
+    (hclean : CacheClean parameter words state.memory.routing.disclosed (CanonicalCoordinate.value otsSecret ftsSecret graph) state.memory.external.cache) :
+    let actual := CanonicalCoordinate.value otsSecret ftsSecret graph
+    let oracle := programmedHash parameter otsSecret ftsSecret graph
+      (finiteHashAnswer ∅ inputs (canonicalPrefixResidual parameter inputs hencoding graph selections rows seed))
+    forgetState <$> observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+      (externalProgram inputs parameter words selections computation) state =
+      fixedByteRun parameter words selections state.memory.routing actual oracle computation state.memory := by
+  dsimp only
+  rw [externalProgram, observedRun_routing_bind]
+  exact byteRun_eq_fixed parameter inputs hencoding words publicReplies selections rows state.memory.routing
+    (CanonicalCoordinate.value otsSecret ftsSecret graph) seed _
+    (fun input => ResidualByteAction.freshPrefix_eq_original parameter inputs hencoding words state.memory.routing.disclosed state.memory.routing.known
+      otsSecret ftsSecret graph publicReplies hagrees hreplies selections rows seed input)
+    computation hinputs state hcovered hmatches hclean
+
+theorem observedRun_jointSigningProgram_memory (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+    (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+    (routing : Routing) (actual : Labels) (seed : inputs → HashOutput) (oracle : QueryImpl HashSpec Id)
+    (hfresh : ∀ input : inputs, ResidualByteAction.eval actual seed
+      (ResidualByteAction.freshPrefix parameter inputs hencoding words routing.disclosed routing.known publicReplies selections rows input) =
+      ResidualByteFrontend.fixedAnswer parameter words routing.disclosed actual oracle input.val)
+    (root : Digest) (message : Message)
+    (hinputs : hashInputs (ResidualByteFrontend.publicSigningWork parameter root routing.known words selections message) ⊆ inputs)
+    (state : State inputs) (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hmatches : ResidualByteFrontend.CacheMatches oracle state.memory.external.cache)
+    (hclean : CacheClean parameter words routing.disclosed actual state.memory.external.cache) :
+    forgetState <$> observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+      (simulateQ (embed inputs routing) (ResidualByteFrontend.jointSigningProgram inputs parameter root routing.known words selections message)) state =
+      (fun record => (some (completePublicSigningRecord (fun index tree leaf => actual (.ftsStart index tree leaf)) record),
+        state.memory.applyBoundary record.2)) <$> 𝒟[publicSigningRecord parameter root oracle routing.known words selections message] := by
+  calc
+    _ = finishWork actual <$> (forgetState <$>
+        byteRun parameter inputs hencoding words publicReplies selections rows routing actual seed
+          (ResidualByteFrontend.publicSigningWork parameter root routing.known words selections message) state) := by
+      rw [ResidualByteFrontend.jointSigningProgram, simulateQ_bind, observedRun_bind, map_bind]
+      simp only [byteRun, map_eq_bind_pure_comp, bind_assoc, pure_bind, Function.comp_def]
+      apply congrArg (_ >>= ·)
+      funext result
+      rcases result with ⟨work, after⟩
+      cases work with
+      | none => simp only [Option.elim_none, pure_bind, finishWork, forgetState]
+      | some work =>
+          change forgetState <$> observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+            (simulateQ (embed inputs routing) (ResidualByteFrontend.jointCompleteSigningWork work)) after = _
+          rw [observedRun_completeWork_memory]
+          rfl
+    _ = _ := by
+      rw [byteRun_message_trace parameter inputs hencoding words publicReplies selections rows routing actual seed oracle hfresh
+        _ hinputs (ResidualByteFrontend.publicSigningWork_messageOnly parameter root routing.known words selections message)
+        state hcovered hmatches hclean]
+      have h := congrArg (fun computation =>
+        (fun result => (some (completePublicSigningRecord (fun index tree leaf => actual (.ftsStart index tree leaf)) result.1), result.2)) <$>
+          𝒟[computation]) (publicSigningWork_fixed_memory parameter root oracle routing.known words selections message state.memory)
+      simpa only [evalDist_map, Functor.map_map, finishWork, Option.elim_some] using h
+
+theorem observedRun_jointSigningProgram_original_memory (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (graph : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary inputs) (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support)
+    (dummy : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (routing : Routing) (message : Message)
+    (hinputs : hashInputs (signWithView key message) ⊆ inputs) (state : State inputs)
+    (hagrees : PublicAgreement (referenceFamilyWords auxiliary.selections dummy) routing.disclosed routing.known
+      (CanonicalCoordinate.value key.otsSecret key.ftsSecret graph))
+    (hreplies : ∀ position, ¬CanonicalCoordinate.Hidden (referenceFamilyWords auxiliary.selections dummy) routing.disclosed (.graph position) →
+      publicReplies position = graph position)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hmatches : ResidualByteFrontend.CacheMatches (programmedHash key.parameter key.otsSecret key.ftsSecret graph
+      (finiteHashAnswer ∅ inputs (canonicalPrefixResidual key.parameter inputs hencoding graph auxiliary.selections auxiliary.rows auxiliary.seed)))
+      state.memory.external.cache)
+    (hclean : CacheClean key.parameter (referenceFamilyWords auxiliary.selections dummy) routing.disclosed
+      (CanonicalCoordinate.value key.otsSecret key.ftsSecret graph) state.memory.external.cache) :
+    let words := referenceFamilyWords auxiliary.selections dummy
+    let actual := CanonicalCoordinate.value key.otsSecret key.ftsSecret graph
+    let oracle := programmedHash key.parameter key.otsSecret key.ftsSecret graph
+      (finiteHashAnswer ∅ inputs (canonicalPrefixResidual key.parameter inputs hencoding graph auxiliary.selections auxiliary.rows auxiliary.seed))
+    forgetState <$> observedRun (environment key.parameter inputs hencoding words publicReplies auxiliary.selections auxiliary.rows) actual auxiliary.seed
+      (simulateQ (embed inputs routing) (ResidualByteFrontend.jointSigningProgram inputs key.parameter key.root routing.known words auxiliary.selections message)) state =
+      (fun record => (some record, state.memory.applyBoundary record.2)) <$>
+        𝒟[fixedBoundaryRun key.parameter oracle (signWithView key message)] := by
+  dsimp only
+  rw [observedRun_jointSigningProgram_memory key.parameter inputs hencoding _ publicReplies auxiliary.selections auxiliary.rows
+    routing (CanonicalCoordinate.value key.otsSecret key.ftsSecret graph) auxiliary.seed _
+    (fun input => ResidualByteAction.freshPrefix_eq_original key.parameter inputs hencoding _ routing.disclosed routing.known
+      key.otsSecret key.ftsSecret graph publicReplies hagrees hreplies auxiliary.selections auxiliary.rows auxiliary.seed input)
+    key.root message ((ResidualByteFrontend.hashInputs_publicSigningWork_subset_signWithView key routing.known _ auxiliary.selections message).trans hinputs)
+    state hcovered hmatches hclean]
+  have hmessage (randomness : Randomness) := programmedPrefixResidual_outside key.parameter inputs hencoding _ routing.disclosed routing.known
+    key.otsSecret key.ftsSecret graph hagrees auxiliary.selections auxiliary.rows auxiliary.seed _
+    (decodePosition_message key.parameter (messageDigestPayload key.root message randomness))
+  have hpublic := fixedBoundaryRun_publicDigestLoop_eq_of_message key.parameter key.root message _ _ hmessage digestAttemptLimit
+  have hrecord := fixedBoundaryRun_signWithView_prefix_public key inputs hencoding graph auxiliary hauxiliary dummy routing.disclosed routing.known hagrees message
+  have h := congrArg (fun computation => (fun record => (some record, state.memory.applyBoundary record.2)) <$> 𝒟[computation]) hrecord
+  simp only [evalDist_map, Functor.map_map, completePublicSigningRecord_trace] at h
+  rw [publicSigningRecord, hpublic]
+  exact h.symm
+
+noncomputable def finishSigning (message : Message) (result : Option SigningRecord × Memory) : Option (Option Signature) × Memory :=
+  result.1.elim (none, result.2) (fun record => (some record.1.1, result.2.recordSigning message record))
+
+theorem observedRun_signingProgram_full_project (parameter : PublicParameter) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+    (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+    (actual : Labels) (seed : inputs → HashOutput) (root : Digest) (message : Message) (state : State inputs) :
+    forgetState <$> observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+      (signingProgram inputs parameter root words selections message) state =
+      finishSigning message <$> (forgetState <$> observedRun (environment parameter inputs hencoding words publicReplies selections rows) actual seed
+        (simulateQ (embed inputs state.memory.routing)
+          (ResidualByteFrontend.jointSigningProgram inputs parameter root state.memory.routing.known words selections message)) state) := by
+  rw [observedRun_signingProgram, map_bind]
+  simp only [map_eq_bind_pure_comp, bind_assoc, pure_bind, Function.comp_def]
+  apply congrArg (_ >>= ·)
+  funext result
+  rcases result with ⟨record, after⟩
+  cases record <;> simp only [Option.elim_none, Option.elim_some, pure_bind, forgetState, finishSigning]
+
+theorem observedRun_signingProgram_original_memory (key : SecretKey) (inputs : Finset HashInput)
+    (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs) (graph : CanonicalGraphLabels)
+    (auxiliary : ReferenceAuxiliary inputs) (hauxiliary : auxiliary ∈ (referenceAuxiliarySample inputs).support)
+    (dummy : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (message : Message)
+    (hinputs : hashInputs (signWithView key message) ⊆ inputs) (state : State inputs)
+    (hagrees : PublicAgreement (referenceFamilyWords auxiliary.selections dummy) state.memory.routing.disclosed state.memory.routing.known
+      (CanonicalCoordinate.value key.otsSecret key.ftsSecret graph))
+    (hreplies : ∀ position, ¬CanonicalCoordinate.Hidden (referenceFamilyWords auxiliary.selections dummy) state.memory.routing.disclosed (.graph position) →
+      publicReplies position = graph position)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hmatches : ResidualByteFrontend.CacheMatches (programmedHash key.parameter key.otsSecret key.ftsSecret graph
+      (finiteHashAnswer ∅ inputs (canonicalPrefixResidual key.parameter inputs hencoding graph auxiliary.selections auxiliary.rows auxiliary.seed)))
+      state.memory.external.cache)
+    (hclean : CacheClean key.parameter (referenceFamilyWords auxiliary.selections dummy) state.memory.routing.disclosed
+      (CanonicalCoordinate.value key.otsSecret key.ftsSecret graph) state.memory.external.cache) :
+    let words := referenceFamilyWords auxiliary.selections dummy
+    let actual := CanonicalCoordinate.value key.otsSecret key.ftsSecret graph
+    let oracle := programmedHash key.parameter key.otsSecret key.ftsSecret graph
+      (finiteHashAnswer ∅ inputs (canonicalPrefixResidual key.parameter inputs hencoding graph auxiliary.selections auxiliary.rows auxiliary.seed))
+    forgetState <$> observedRun (environment key.parameter inputs hencoding words publicReplies auxiliary.selections auxiliary.rows) actual auxiliary.seed
+      (signingProgram inputs key.parameter key.root words auxiliary.selections message) state =
+      (fun record => (some record.1.1, (state.memory.applyBoundary record.2).recordSigning message record)) <$>
+        𝒟[fixedBoundaryRun key.parameter oracle (signWithView key message)] := by
+  dsimp only
+  rw [observedRun_signingProgram_full_project,
+    observedRun_jointSigningProgram_original_memory key inputs hencoding graph auxiliary hauxiliary dummy publicReplies
+      state.memory.routing message hinputs state hagrees hreplies hcovered hmatches hclean]
+  simp only [Functor.map_map, finishSigning, Option.elim_some]
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualSource.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualSource.lean
new file mode 100644
index 000000000..8e6c4c50b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualSource.lean
@@ -0,0 +1,163 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualContext
+import SphincsSecurity.Proof.Residual.RetainedResidualRows
+import SphincsSecurity.Proof.Residual.RetainedResidualSigningTrace
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable instance signatureFintype : Fintype Signature := by
+  classical
+  exact Fintype.ofEquiv
+    (Randomness × (FtsTree → Digest) × (FtsTree → Fin ftsTreeHeight → Digest) ×
+      (Layer → Counter) × (Layer → ChainIndex → Digest) × (PathIndex → Digest))
+    { toFun := fun s => ⟨s.1, s.2.1, s.2.2.1, s.2.2.2.1, s.2.2.2.2.1, s.2.2.2.2.2⟩
+      invFun := fun s => (s.randomness, s.ftsSecret, s.ftsPath, s.counter, s.chainValue, s.authPath)
+      left_inv := fun _ => rfl
+      right_inv := fun _ => rfl }
+
+noncomputable local instance instFintypeRangeOracleWorldSigningSpec (input : (OracleWorld + SigningSpec).Domain) :
+    Fintype ((OracleWorld + SigningSpec).Range input) := by
+  cases input <;> infer_instance
+
+noncomputable def requestInputs (key : SecretKey) : (OracleWorld + SigningSpec).Domain → Finset HashInput
+  | .inl input => hashInputs (liftM (OracleWorld.query input))
+  | .inr message => hashInputs (signWithView key message)
+
+noncomputable def sourceInputs {Result : Type} (key : SecretKey)
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) : Finset HashInput :=
+  OracleComp.construct (fun _ => ∅)
+    (fun input _ tail => requestInputs key input ∪ Finset.univ.biUnion tail) computation
+
+theorem sourceInputs_pure {Result : Type} (key : SecretKey) (value : Result) :
+    sourceInputs key (pure value) = ∅ := rfl
+
+theorem sourceInputs_query_bind {Result : Type} (key : SecretKey) (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Result) :
+    sourceInputs key (liftM ((OracleWorld + SigningSpec).query input) >>= next) =
+      requestInputs key input ∪ Finset.univ.biUnion (fun answer => sourceInputs key (next answer)) := by
+  simp only [sourceInputs, OracleComp.construct_query_bind]
+
+theorem requestInputs_subset {Result : Type} (key : SecretKey) (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Result) :
+    requestInputs key input ⊆ sourceInputs key (liftM ((OracleWorld + SigningSpec).query input) >>= next) := by
+  rw [sourceInputs_query_bind]
+  exact Finset.subset_union_left
+
+theorem sourceInputs_next_subset {Result : Type} (key : SecretKey) (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Result)
+    (answer : (OracleWorld + SigningSpec).Range input) :
+    sourceInputs key (next answer) ⊆ sourceInputs key (liftM ((OracleWorld + SigningSpec).query input) >>= next) := by
+  intro row hrow
+  rw [sourceInputs_query_bind, Finset.mem_union]
+  exact Or.inr (Finset.mem_biUnion.mpr ⟨answer, Finset.mem_univ _, hrow⟩)
+
+noncomputable def fixedSourceImpl {inputs : Finset HashInput} (context : Context inputs) :
+    QueryImpl (OracleWorld + SigningSpec) (OptionT (StateT Memory SPMF))
+  | .inl input => OptionT.mk <| StateT.mk fun memory =>
+      fixedByteRun context.key.parameter context.words context.auxiliary.selections memory.routing
+        context.actual context.oracle (liftM (OracleWorld.query input)) memory
+  | .inr message => OptionT.mk <| StateT.mk fun memory =>
+      (fun record : SigningRecord => (some record.1.1, (memory.applyBoundary record.2).recordSigning message record)) <$>
+        𝒟[fixedBoundaryRun context.key.parameter context.oracle (signWithView context.key message)]
+
+noncomputable def fixedSourceRun {Result : Type} {inputs : Finset HashInput} (context : Context inputs)
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) (memory : Memory) : SPMF (Option Result × Memory) :=
+  (OptionT.run (simulateQ (fixedSourceImpl context) computation)).run memory
+
+theorem fixedSourceRun_pure {Result : Type} {inputs : Finset HashInput} (context : Context inputs)
+    (value : Result) (memory : Memory) : fixedSourceRun context (pure value) memory = pure (some value, memory) := by
+  simp only [fixedSourceRun, simulateQ_pure, OptionT.run_pure, StateT.run_pure]
+
+theorem fixedSourceRun_query_bind {Result : Type} {inputs : Finset HashInput} (context : Context inputs)
+    (input : (OracleWorld + SigningSpec).Domain)
+    (next : (OracleWorld + SigningSpec).Range input → OracleComp (OracleWorld + SigningSpec) Result) (memory : Memory) :
+    fixedSourceRun context (liftM ((OracleWorld + SigningSpec).query input) >>= next) memory =
+      ((fixedSourceImpl context input).run.run memory >>= fun result =>
+        result.1.elim (pure (none, result.2)) (fun answer => fixedSourceRun context (next answer) result.2)) := by
+  simp only [fixedSourceRun, simulateQ_bind, simulateQ_spec_query, OptionT.run_bind, Option.elimM, StateT.run_bind]
+  apply congrArg (_ >>= ·)
+  funext result
+  rcases result with ⟨answer, after⟩
+  cases answer <;> rfl
+
+theorem Context.external_memory {Result : Type} {inputs : Finset HashInput} (context : Context inputs)
+    (computation : OracleComp OracleWorld Result) (hinputs : hashInputs computation ⊆ inputs)
+    (state : State inputs) (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hcompatible : Compatible context state.memory) :
+    forgetState <$> observedRun context.environment context.actual context.auxiliary.seed
+      (externalProgram inputs context.key.parameter context.words context.auxiliary.selections computation) state =
+      fixedByteRun context.key.parameter context.words context.auxiliary.selections state.memory.routing
+        context.actual context.oracle computation state.memory :=
+  observedRun_externalProgram_original_memory context.key.parameter inputs context.encoding context.words
+    context.publicReplies context.auxiliary.selections context.auxiliary.rows context.key.otsSecret context.key.ftsSecret
+    context.graph context.auxiliary.seed computation hinputs state hcompatible.agrees hcompatible.replies hcovered
+    hcompatible.cached hcompatible.structural
+
+theorem Context.signing_memory {inputs : Finset HashInput} (context : Context inputs) (message : Message)
+    (hinputs : hashInputs (signWithView context.key message) ⊆ inputs)
+    (state : State inputs) (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hcompatible : Compatible context state.memory) :
+    forgetState <$> observedRun context.environment context.actual context.auxiliary.seed
+      (signingProgram inputs context.key.parameter context.key.root context.words context.auxiliary.selections message) state =
+      (fun record : SigningRecord => (some record.1.1, (state.memory.applyBoundary record.2).recordSigning message record)) <$>
+        𝒟[fixedBoundaryRun context.key.parameter context.oracle (signWithView context.key message)] :=
+  observedRun_signingProgram_original_memory context.key inputs context.encoding context.graph context.auxiliary
+    context.auxiliary_valid context.dummy context.publicReplies message hinputs state hcompatible.agrees hcompatible.replies
+    hcovered hcompatible.cached hcompatible.structural
+
+theorem observedRun_request_memory {inputs : Finset HashInput} (context : Context inputs)
+    (input : (OracleWorld + SigningSpec).Domain) (hinputs : requestInputs context.key input ⊆ inputs)
+    (state : State inputs) (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hcompatible : Compatible context state.memory) :
+    forgetState <$> observedRun context.environment context.actual context.auxiliary.seed
+      (adversaryImpl inputs context.key.parameter context.key.root context.words context.auxiliary.selections input) state =
+      (fixedSourceImpl context input).run.run state.memory := by
+  cases input with
+  | inl input =>
+      rw [adversaryImpl, fixedSourceImpl, OptionT.run_mk, StateT.run_mk]
+      exact context.external_memory _ hinputs state hcovered hcompatible
+  | inr message =>
+      rw [adversaryImpl, fixedSourceImpl, OptionT.run_mk, StateT.run_mk]
+      exact context.signing_memory message hinputs state hcovered hcompatible
+
+theorem fixedSourceImpl_compatible {inputs : Finset HashInput} (context : Context inputs)
+    (input : (OracleWorld + SigningSpec).Domain) (memory : Memory) (hcompatible : Compatible context memory)
+    (answer : (OracleWorld + SigningSpec).Range input) (after : Memory)
+    (hresult : (fixedSourceImpl context input).run.run memory (some answer, after) ≠ 0) : Compatible context after := by
+  cases input with
+  | inl input =>
+      simp only [fixedSourceImpl, OptionT.run_mk, StateT.run_mk, fixedByteRun, simulateQ_spec_query] at hresult
+      cases input with
+      | inl input =>
+          simp only [fixedByteImpl, OptionT.run_mk, StateT.run_mk, RetainedObservation.bind_nonzero] at hresult
+          obtain ⟨value, _, hresult⟩ := hresult
+          simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not, Prod.mk.injEq] at hresult
+          exact hresult.2 ▸ hcompatible
+      | inr input =>
+          simp only [fixedByteImpl, OptionT.run_mk, StateT.run_mk, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+          have h := fixedHashStep_compatible context input memory hcompatible answer (congrArg Prod.fst hresult).symm
+          simpa only [← hresult] using h
+  | inr message =>
+      simp only [fixedSourceImpl, OptionT.run_mk, StateT.run_mk, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨record, hrecord, hresult⟩ := hresult
+      simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not, Prod.mk.injEq] at hresult
+      exact hresult.2 ▸ originalSigning_compatible context memory hcompatible message record hrecord
+
+theorem observedRun_request_compatible {inputs : Finset HashInput} (context : Context inputs)
+    (input : (OracleWorld + SigningSpec).Domain) (hinputs : requestInputs context.key input ⊆ inputs)
+    (state : State inputs) (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hcompatible : Compatible context state.memory) (answer : (OracleWorld + SigningSpec).Range input) (after : State inputs)
+    (hresult : observedRun context.environment context.actual context.auxiliary.seed
+      (adversaryImpl inputs context.key.parameter context.key.root context.words context.auxiliary.selections input) state (some answer, after) ≠ 0) :
+    Compatible context after.memory := by
+  have h := map_nonzero _ forgetState (some answer, after) hresult
+  rw [observedRun_request_memory context input hinputs state hcovered hcompatible] at h
+  exact fixedSourceImpl_compatible context input state.memory hcompatible answer after.memory h
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualStrongCoverage.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualStrongCoverage.lean
new file mode 100644
index 000000000..c9d0d76b3
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualStrongCoverage.lean
@@ -0,0 +1,131 @@
+import SphincsSecurity.Proof.Residual.RetainedResidualSigningHistory
+import SphincsSecurity.Proof.Fts.BankedTargetEnvelope
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] signDigestLoop signAfterDigest boundaryEval
+set_option backward.isDefEq.respectTransparency false
+
+theorem SigningHistory.digestsCached {key : SecretKey} {oracle : QueryImpl HashSpec Id} {memory : Memory}
+    (hhistory : SigningHistory key oracle memory) : SigningDigestsCached key.parameter memory.external.cache key.root memory.log := by
+  intro entry hentry signature hsignature
+  have hentry' : (⟨entry.1, some signature⟩ : SigningEntry) ∈ memory.log := by
+    simpa only [← hsignature] using hentry
+  exact (hhistory.entries entry.1 signature hentry').1
+
+theorem SigningHistory.signing_payload_ne {inputs : Finset HashInput} {context : Context inputs} {memory : Memory}
+    (hhistory : SigningHistory context.key context.oracle memory) (hcompatible : Compatible context memory)
+    (hdummy : ∀ lay tree leaf, TargetSum.Valid (context.dummy lay tree leaf)) (forgery : Forgery)
+    (hnew : ¬ SigningTranscript.Contains memory.log forgery)
+    (hfull : let digest := truncateMessageDigest (context.oracle (signingInput context.key forgery.message forgery.signature))
+      FullyHonestOpening context.oracle memory.external.cache context.key (digestIndex digest) (digestLeaves digest) forgery.signature)
+    (message : Message) (signature : Signature) (hentry : (⟨message, some signature⟩ : SigningEntry) ∈ memory.log) :
+    messageDigestPayload context.key.root message signature.randomness ≠
+      messageDigestPayload context.key.root forgery.message forgery.signature.randomness := by
+  intro heq
+  obtain ⟨hmessage, hrandomness⟩ := messageDigestPayload_injective context.key.root heq
+  have hsign := (hhistory.entries message signature hentry).2.2
+  dsimp only [signingInput] at hsign
+  rw [heq] at hsign
+  have hsignature := hcompatible.honest_signature_eq hdummy _ _ forgery.signature signature hfull hsign hrandomness
+  exact hnew ⟨⟨message, some signature⟩, hentry, hmessage, congrArg some hsignature⟩
+
+theorem SigningHistory.strong_covered {inputs : Finset HashInput} {context : Context inputs} {memory : Memory}
+    (hhistory : SigningHistory context.key context.oracle memory) (hcompatible : Compatible context memory)
+    (hdummy : ∀ lay tree leaf, TargetSum.Valid (context.dummy lay tree leaf)) (forgery : Forgery)
+    (hnew : ¬ SigningTranscript.Contains memory.log forgery)
+    (hfull : let digest := truncateMessageDigest (context.oracle (signingInput context.key forgery.message forgery.signature))
+      FullyHonestOpening context.oracle memory.external.cache context.key (digestIndex digest) (digestLeaves digest) forgery.signature)
+    (hdisclosed : ∀ tree, memory.routing.disclosed (signingView context.key context.oracle forgery.message forgery.signature).1
+      tree ((signingView context.key context.oracle forgery.message forgery.signature).2 tree)) :
+    CoveredFewTimeView (fixedSigningViews context.key.parameter memory.external.cache context.key.root memory.log
+      (signingInput context.key forgery.message forgery.signature)) (signingView context.key context.oracle forgery.message forgery.signature) := by
+  intro tree
+  obtain ⟨message, signature, hentry, hindex, hleaf⟩ := hhistory.disclosed _ tree _ (hdisclosed tree)
+  have hne := hhistory.signing_payload_ne hcompatible hdummy forgery hnew hfull message signature hentry
+  have horigin := hhistory.entries message signature hentry
+  obtain ⟨answer, hcache⟩ := Option.ne_none_iff_exists'.mp horigin.1
+  have hcached : memory.external.cache (signingInput context.key message signature) =
+      some (context.oracle (signingInput context.key message signature)) :=
+    hcache.trans (congrArg some (hcompatible.cached _ _ hcache))
+  obtain ⟨slot, hslot⟩ := List.mem_iff_get.mp hentry
+  refine ⟨slot, signingView context.key context.oracle message signature, ?_, hindex.symm, hleaf.symm⟩
+  change eligibleSigningView? _ _ _ (memory.log.get slot) = _
+  rw [hslot]
+  simp only [eligibleSigningView?, signingInput,
+    payloadOf_tweakableHashInput, Option.bind_eq_bind', Option.bind_some, if_neg hne, observedSigningView?, FtsProbeSimulation.messageAnswers]
+  change (memory.external.cache (signingInput context.key message signature) >>= fun answer => pure (hashOutputFewTimeView answer)) = _
+  rw [hcached]
+  rfl
+
+theorem fixedSourceRun_rest_strong_covered {inputs : Finset HashInput} (context : Context inputs)
+    (memory : Memory) (hcompatible : Compatible context memory) (hhistory : SigningHistory context.key context.oracle memory)
+    (hdummy : ∀ lay tree leaf, TargetSum.Valid (context.dummy lay tree leaf))
+    (hroot : context.key.root = canonicalGraphRoot context.graph) (adversary : Adversary) (forgery : Forgery) (after : Memory)
+    (hresult : fixedSourceRun context
+      (FtsProbeSimulation.unloggedRetainedRestComputation adversary ⟨context.key.root, context.key.parameter⟩)
+        memory (some (forgery, true), after) ≠ 0)
+    (hnew : ¬ SigningTranscript.Contains after.log forgery) :
+    Admissible (truncateMessageDigest (context.oracle (signingInput context.key forgery.message forgery.signature))) ∧
+      SigningDigestsCached context.key.parameter after.external.cache context.key.root after.log ∧
+      CoveredFewTimeView (fixedSigningViews context.key.parameter after.external.cache context.key.root after.log
+        (signingInput context.key forgery.message forgery.signature)) (signingView context.key context.oracle forgery.message forgery.signature) := by
+  have hcompatible' := fixedSourceRun_compatible context _ memory hcompatible (forgery, true) after hresult
+  have hhistory' := fixedSourceRun_signingHistory context _ memory hhistory (forgery, true) after hresult
+  obtain ⟨digest, hdigest, _, hadmissible, hfull, hdisclosed⟩ :=
+    fixedSourceRun_rest_honest context memory hcompatible hdummy hroot adversary forgery after hresult
+  have heval : evalWithAnswerFn context.oracle
+      (messageDigest context.key.parameter context.key.root forgery.message forgery.signature.randomness) =
+      truncateMessageDigest (context.oracle (signingInput context.key forgery.message forgery.signature)) := by
+    simp only [messageDigest, oracleHash, evalWithAnswerFn_bind, evalWithAnswerFn_pure]
+    rfl
+  have hdigest' := hdigest.symm.trans heval
+  rw [hdigest'] at hadmissible hfull hdisclosed
+  exact ⟨hadmissible, hhistory'.digestsCached, hhistory'.strong_covered hcompatible' hdummy forgery hnew hfull hdisclosed⟩
+
+theorem fixedSourceRun_rest_certificate {inputs : Finset HashInput} (context : Context inputs)
+    (memory : Memory) (hcompatible : Compatible context memory) (hhistory : SigningHistory context.key context.oracle memory)
+    (hdummy : ∀ lay tree leaf, TargetSum.Valid (context.dummy lay tree leaf))
+    (hroot : context.key.root = canonicalGraphRoot context.graph) (adversary : Adversary) (forgery : Forgery) (after : Memory)
+    (hresult : fixedSourceRun context
+      (FtsProbeSimulation.unloggedRetainedRestComputation adversary ⟨context.key.root, context.key.parameter⟩)
+        memory (some (forgery, true), after) ≠ 0)
+    (hnew : ¬ SigningTranscript.Contains after.log forgery) :
+    TargetCertificateAt context.key Finset.univ (after.external.cache, after.log)
+      (signingInput context.key forgery.message forgery.signature) := by
+  obtain ⟨hadmissible, _, hcoverage⟩ :=
+    fixedSourceRun_rest_strong_covered context memory hcompatible hhistory hdummy hroot adversary forgery after hresult hnew
+  obtain ⟨_, _, hcached, _⟩ := fixedSourceRun_rest_honest context memory hcompatible hdummy hroot adversary forgery after hresult
+  have hpresent : after.external.cache (signingInput context.key forgery.message forgery.signature) ≠ none := by
+    apply hcached
+    change signingInput context.key forgery.message forgery.signature ∈ [signingInput context.key forgery.message forgery.signature]
+    exact List.mem_singleton_self _
+  obtain ⟨answer, hanswer⟩ := Option.ne_none_iff_exists'.mp hpresent
+  have hcompatible' := fixedSourceRun_compatible context _ memory hcompatible (forgery, true) after hresult
+  refine ⟨context.oracle (signingInput context.key forgery.message forgery.signature),
+    hanswer.trans (congrArg some (hcompatible'.cached _ _ hanswer)), ?_, hadmissible, ?_⟩
+  · exact ⟨messageDigestPayload context.key.root forgery.message forgery.signature.randomness, rfl⟩
+  · intro tree _
+    exact (targetTreeMatchCount_pos_iff _ _ tree).mpr (hcoverage tree)
+
+theorem observedRun_rest_certificate {inputs : Finset HashInput} (context : Context inputs) (adversary : Adversary)
+    (hinputs : sourceInputs context.key
+      (FtsProbeSimulation.unloggedRetainedRestComputation adversary ⟨context.key.root, context.key.parameter⟩) ⊆ inputs)
+    (state : State inputs) (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hcompatible : Compatible context state.memory) (hhistory : SigningHistory context.key context.oracle state.memory)
+    (hdummy : ∀ lay tree leaf, TargetSum.Valid (context.dummy lay tree leaf))
+    (hroot : context.key.root = canonicalGraphRoot context.graph) (forgery : Forgery) (after : State inputs)
+    (hresult : observedRun context.environment context.actual context.auxiliary.seed
+      (simulateQ (adversaryImpl inputs context.key.parameter context.key.root context.words context.auxiliary.selections)
+        (FtsProbeSimulation.unloggedRetainedRestComputation adversary ⟨context.key.root, context.key.parameter⟩))
+      state (some (forgery, true), after) ≠ 0)
+    (hnew : ¬ SigningTranscript.Contains after.memory.log forgery) :
+    TargetCertificateAt context.key Finset.univ (after.memory.external.cache, after.memory.log)
+      (signingInput context.key forgery.message forgery.signature) := by
+  have h := map_nonzero _ forgetState (some (forgery, true), after) hresult
+  rw [observedRun_source_memory context _ hinputs state hcovered hcompatible] at h
+  exact fixedSourceRun_rest_certificate context state.memory hcompatible hhistory hdummy hroot adversary forgery after.memory h hnew
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualSuccessTransfer.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualSuccessTransfer.lean
new file mode 100644
index 000000000..8a98a524d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualSuccessTransfer.lean
@@ -0,0 +1,141 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualComposition
+import SphincsSecurity.Proof.Residual.RetainedSigningTrace
+import SphincsSecurity.Proof.Fts.StoppedSigningLog
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open FtsProbeSimulation (withSigningLog)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs sourceInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+  signDigestLoop signAfterDigest sequenceFin chainWalk
+set_option backward.isDefEq.respectTransparency false
+
+def StoppedOr {Result : Type} (event : Result → QueryLog SigningSpec → Prop) (result : Option Result × Memory) : Prop :=
+  result.1.elim True (fun value => event value result.2.log)
+
+theorem fixedHashStep_answer {inputs : Finset HashInput} (context : Context inputs) (input : HashInput) (memory : Memory) :
+    (fixedHashStep context.key.parameter context.words context.auxiliary.selections memory.routing context.actual context.oracle input memory).1 = none ∨
+    (fixedHashStep context.key.parameter context.words context.auxiliary.selections memory.routing context.actual context.oracle input memory).1 =
+      some (context.oracle input) := by
+  unfold fixedHashStep ResidualByteFrontend.fixedStep ResidualByteFrontend.fixedAnswer ResidualByteFrontend.checkedResult
+  split
+  · exact Or.inl rfl
+  · dsimp only [Option.bind_some]
+    split
+    · exact Or.inl rfl
+    · exact Or.inr rfl
+
+theorem fixedHashStep_log {inputs : Finset HashInput} (context : Context inputs) (input : HashInput) (memory : Memory) :
+    (fixedHashStep context.key.parameter context.words context.auxiliary.selections memory.routing context.actual context.oracle input memory).2.log =
+      memory.log := by
+  exact congrArg (fun history => history.2.1) (afterReply_history context.key.parameter memory input _ _)
+
+private theorem fixedOriginal_sign_bind {Result : Type} (key : SecretKey) (oracle : QueryImpl HashSpec Id)
+    (message : Message) (next : Option Signature → OracleComp OracleWorld Result) :
+    simulateQ (fixedHashWorld oracle) (scheme.sign key message >>= next) =
+      fixedBoundaryRun key.parameter oracle (signWithView key message) >>= fun record =>
+        simulateQ (fixedHashWorld oracle) (next record.1.1) := by
+  rw [show scheme.sign key message = sign key message from rfl,
+    ← signWithView_fst key message, bind_map_left, simulateQ_bind,
+    ← fixedBoundaryRun_forget key.parameter oracle (signWithView key message), bind_map_left]
+
+theorem prob_originalSource_le_stopped {Result : Type} {inputs : Finset HashInput} (context : Context inputs)
+    (computation : OracleComp (OracleWorld + SigningSpec) Result) (memory : Memory)
+    (event : Result → QueryLog SigningSpec → Prop) :
+    Pr[fun result => event result.1 result.2 |
+      simulateQ (fixedHashWorld context.oracle)
+        (simulateQ (expandedAdversaryImpl context.key) (withSigningLog computation memory.log))] ≤
+      Pr[StoppedOr event | fixedSourceRun context computation memory] := by
+  induction computation using OracleComp.inductionOn generalizing memory with
+  | pure value =>
+      simp only [FtsProbeSimulation.withSigningLog_pure, simulateQ_pure, fixedSourceRun_pure,
+        probEvent_pure, StoppedOr, Option.elim_some, le_refl]
+  | query_bind input next ih =>
+      rw [FtsProbeSimulation.withSigningLog_query_bind, fixedSourceRun_query_bind]
+      cases input with
+      | inl input =>
+          rw [simulateQ_expandedAdversaryImpl_query_bind_inl, simulateQ_bind, simulateQ_spec_query]
+          simp only [fixedSourceImpl, OptionT.run_mk, StateT.run_mk, fixedByteRun, simulateQ_spec_query,
+            signingLogFragment, List.append_nil]
+          cases input with
+          | inl input =>
+              simp only [fixedHashWorld, fixedByteImpl, OptionT.run_mk, StateT.run_mk, bind_assoc, pure_bind,
+                Option.elim_some, probEvent_bind_eq_tsum, probOutput_query, SPMF.probOutput_liftM,
+                PMF.probOutput_eq_apply, PMF.uniformOfFintype_apply]
+              apply ENNReal.tsum_le_tsum
+              intro answer
+              exact mul_le_mul' le_rfl (ih answer memory)
+          | inr input =>
+              simp only [fixedHashWorld, fixedByteImpl, OptionT.run_mk, StateT.run_mk, pure_bind]
+              rcases fixedHashStep_answer context input memory with hstop | hlive
+              · rw [hstop, Option.elim_none]
+                simp only [probEvent_pure, StoppedOr, Option.elim_none, if_true]
+                exact probEvent_le_one
+              · rw [hlive, Option.elim_some]
+                have h := ih (context.oracle input)
+                  (fixedHashStep context.key.parameter context.words context.auxiliary.selections memory.routing context.actual context.oracle input memory).2
+                rw [fixedHashStep_log] at h
+                exact h
+      | inr message =>
+          rw [simulateQ_expandedAdversaryImpl_query_bind_inr, fixedOriginal_sign_bind]
+          simp only [fixedSourceImpl, OptionT.run_mk, StateT.run_mk, bind_map_left, Option.elim_some,
+            probEvent_bind_eq_tsum]
+          apply ENNReal.tsum_le_tsum
+          intro record
+          apply mul_le_mul'
+          · simp only [probOutput_def, SPMF.evalDist_def, le_refl]
+          · have h := ih record.1.1 ((memory.applyBoundary record.2).recordSigning message record)
+            have hlog : ((memory.applyBoundary record.2).recordSigning message record).log =
+                memory.log ++ signingLogFragment (.inr message) record.1.1 := rfl
+            rw [hlog] at h
+            exact h
+
+def sourceVerdict (result : Forgery × Bool) (log : QueryLog SigningSpec) : Bool :=
+  decide (SigningTranscript.Valid log ∧ ¬SigningTranscript.Contains log result.1) && result.2
+
+theorem fixedOriginal_gameRest (key : SecretKey) (oracle : QueryImpl HashSpec Id) (adversary : Adversary) :
+    simulateQ (fixedHashWorld oracle) (gameRest scheme adversary ⟨key.root, key.parameter⟩ key) =
+      (fun result => sourceVerdict result.1 result.2) <$>
+        simulateQ (fixedHashWorld oracle) (simulateQ (expandedAdversaryImpl key)
+          (withSigningLog (FtsProbeSimulation.unloggedRetainedRestComputation adversary ⟨key.root, key.parameter⟩) [])) := by
+  rw [← FtsProbeSimulation.simulateQ_expanded_tracedGameRestComputation,
+    ← FtsProbeSimulation.retainedGameRestComputation_verdict_projection,
+    FtsProbeSimulation.retainedGameRestComputation_eq_signingTrace]
+  simp only [simulateQ_map, Functor.map_map, withSigningLog, List.nil_append]
+  rfl
+
+theorem prob_gameRest_le_stopped {inputs : Finset HashInput} (context : Context inputs)
+    (adversary : Adversary) (memory : Memory) (hlog : memory.log = []) :
+    Pr[fun verdict => verdict = true |
+      simulateQ (fixedHashWorld context.oracle)
+        (gameRest scheme adversary ⟨context.key.root, context.key.parameter⟩ context.key)] ≤
+      Pr[StoppedOr (fun result log => sourceVerdict result log = true) |
+        fixedSourceRun context
+          (FtsProbeSimulation.unloggedRetainedRestComputation adversary ⟨context.key.root, context.key.parameter⟩) memory] := by
+  rw [fixedOriginal_gameRest, probEvent_map]
+  have h := prob_originalSource_le_stopped context
+    (FtsProbeSimulation.unloggedRetainedRestComputation adversary ⟨context.key.root, context.key.parameter⟩)
+    memory (fun result log => sourceVerdict result log = true)
+  rw [hlog] at h
+  exact h
+
+theorem prob_gameRest_le_observed {inputs : Finset HashInput} (context : Context inputs)
+    (adversary : Adversary)
+    (hinputs : sourceInputs context.key
+      (FtsProbeSimulation.unloggedRetainedRestComputation adversary ⟨context.key.root, context.key.parameter⟩) ⊆ inputs)
+    (state : State inputs) (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hcompatible : Compatible context state.memory) (hlog : state.memory.log = []) :
+    Pr[fun verdict => verdict = true |
+      simulateQ (fixedHashWorld context.oracle)
+        (gameRest scheme adversary ⟨context.key.root, context.key.parameter⟩ context.key)] ≤
+      Pr[fun result => StoppedOr (fun value log => sourceVerdict value log = true) (forgetState result) |
+        observedRun context.environment context.actual context.auxiliary.seed
+          (simulateQ (adversaryImpl inputs context.key.parameter context.key.root context.words context.auxiliary.selections)
+            (FtsProbeSimulation.unloggedRetainedRestComputation adversary ⟨context.key.root, context.key.parameter⟩)) state] := by
+  have h := prob_gameRest_le_stopped context adversary state.memory hlog
+  rw [← observedRun_source_memory context _ hinputs state hcovered hcompatible, probEvent_map] at h
+  exact h
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualTerminalCoverage.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualTerminalCoverage.lean
new file mode 100644
index 000000000..c4cf2c139
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualTerminalCoverage.lean
@@ -0,0 +1,156 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualOriginalBudget
+import SphincsSecurity.Proof.Residual.RetainedResidualProposalPayment
+import SphincsSecurity.Proof.Fts.UnitCertificateCoverage
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec ENNReal CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open FtsProbeSimulation (unloggedRetainedRestComputation)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs sourceInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+theorem terminalProposalPotential_le_baseline_excess (total : Nat) (payoff : List Index → ENNReal)
+    (baseline : ENNReal) (consumed : List Index) :
+    terminalProposalPotential (PMF.uniformOfFintype Index) total payoff consumed ≤
+      baseline + terminalProposalPotential (PMF.uniformOfFintype Index) total (fun word => payoff word - baseline) consumed := by
+  unfold terminalProposalPotential
+  calc
+    _ ≤ ∑' word, Pr[= word | completeProposalWord (PMF.uniformOfFintype Index) total consumed] *
+        (baseline + (payoff word - baseline)) :=
+      ENNReal.tsum_le_tsum fun word => mul_le_mul' le_rfl le_add_tsub
+    _ = _ := by
+      simp only [mul_add, ENNReal.tsum_add, ENNReal.tsum_mul_right, PMF.probOutput_eq_apply, PMF.tsum_coe, one_mul]
+
+theorem terminalProposalPotential_empty (total : Nat) (payoff : List Index → ENNReal) :
+    terminalProposalPotential (PMF.uniformOfFintype Index) total payoff [] = uniformWordAverage total payoff := by
+  simp only [terminalProposalPotential, uniformWordAverage, completeProposalWord_nil, probOutput_def,
+    evalDist_sampleUniformProposalWord, PMF.evalDist_eq]
+
+theorem expected_weighted_terminalPotential_le {Result : Type} (law : SPMF Result)
+    (consumed : Result → List Index) (mass : Result → ENNReal) (bound baseline : ENNReal)
+    (hmass : ∀ result, law result ≠ 0 → mass result ≤ bound) (total : Nat) (payoff : List Index → ENNReal) :
+    (∑' result, Pr[= result | law] *
+      (mass result * terminalProposalPotential (PMF.uniformOfFintype Index) total payoff (consumed result))) ≤
+        baseline * (∑' result, Pr[= result | law] * mass result) +
+          bound * ∑' result, Pr[= result | law] *
+            terminalProposalPotential (PMF.uniformOfFintype Index) total (fun word => payoff word - baseline) (consumed result) := by
+  calc
+    _ ≤ ∑' result, Pr[= result | law] *
+        (baseline * mass result + bound *
+          terminalProposalPotential (PMF.uniformOfFintype Index) total (fun word => payoff word - baseline) (consumed result)) := by
+      apply ENNReal.tsum_le_tsum
+      intro result
+      by_cases hr : Pr[= result | law] = 0
+      · simp only [hr, zero_mul, le_refl]
+      · apply mul_le_mul' le_rfl
+        calc
+          _ ≤ mass result * (baseline + terminalProposalPotential (PMF.uniformOfFintype Index) total
+              (fun word => payoff word - baseline) (consumed result)) :=
+            mul_le_mul' le_rfl (terminalProposalPotential_le_baseline_excess total payoff baseline (consumed result))
+          _ ≤ _ := by
+            rw [mul_add, mul_comm (mass result) baseline]
+            exact add_le_add le_rfl (mul_le_mul' (hmass result (by rwa [SPMF.probOutput_eq_apply] at hr)) le_rfl)
+    _ = _ := by
+      simp only [mul_add, ENNReal.tsum_add, mul_left_comm _ baseline, mul_left_comm _ bound, ENNReal.tsum_mul_left]
+
+theorem uniformWordAverage_full_price_excess_le :
+    uniformWordAverage fixedProposalLength
+      (fun word => terminalCertificatePrice Finset.univ word - (2 ^ 128 : ENNReal)⁻¹) ≤ (11 / 2 ^ 144 : ENNReal) := by
+  have hscale (word : List Index) :
+      terminalCertificatePrice Finset.univ word - (2 ^ 128 : ENNReal)⁻¹ =
+        (2 ^ 128 : ENNReal)⁻¹ * (fixedFullProposalPrice word - 1) := by
+    rw [terminalCertificatePrice_full, ENNReal.mul_sub (fun _ _ => by finiteness), mul_one]
+  simp_rw [hscale]
+  rw [uniformWordAverage_mul_left]
+  calc
+    _ ≤ (2 ^ 128 : ENNReal)⁻¹ * (11 / 2 ^ 16 : ENNReal) :=
+      mul_le_mul' le_rfl uniformWordAverage_fixedFull_unit_excess_le
+    _ = _ := by
+      apply (ENNReal.toReal_eq_toReal_iff' (by finiteness) (by finiteness)).mp
+      norm_num [ENNReal.toReal_mul, ENNReal.toReal_inv, ENNReal.toReal_div, ENNReal.toReal_pow]
+
+theorem expected_initialMonitoredSource_full_unit_count_le
+    (key : SecretKey) (adversary : Adversary) (encoding : ReferenceEncodingAuxiliary) (dummy : OtsReferenceWords)
+    (exposed : InitialPublicLabels (referenceFamilyWords encoding.selections dummy)) (high : CanonicalGraphHighHalves)
+    (q : Nat) (stopAfter : CertificateStopRule) (stopped : Bool)
+    (hparameter : key.parameter ∈ support sampleParameter) (hencoding : encoding ∈ referenceEncodingAuxiliarySample.support)
+    (hroot : key.root = knownRoot (initialKnown (referenceFamilyWords encoding.selections dummy) exposed))
+    (hq : HasHashQueryBound scheme adversary q) (hbudget : q ≤ 2 ^ 127) :
+    (∑' result, Pr[= result | initialMonitoredSource key adversary encoding dummy exposed high q Finset.univ (proposalStop stopAfter) stopped] *
+      certificateBankCount result.2.2.bank) ≤
+        (2 ^ 128 : ENNReal)⁻¹ *
+          (∑' result, Pr[= result | initialMonitoredSource key adversary encoding dummy exposed high q Finset.univ (proposalStop stopAfter) stopped] *
+            result.2.1.memory.messageCalls.length) + (q : ENNReal) * (11 / 2 ^ 144 : ENNReal) := by
+  let state : ProposalState (gameInputs adversary) :=
+    ([], initialState (gameInputs adversary) (referenceFamilyWords encoding.selections dummy) exposed, initialCertificateMonitor 1212415 stopped)
+  let law := proposalRun key (gameInputs adversary) (canonicalEncodingInputs_subset_retainedGameInputs adversary key.parameter)
+    (referenceFamilyWords encoding.selections dummy)
+    (coordinateGraphLabels (initialKnown (referenceFamilyWords encoding.selections dummy) exposed) high)
+    encoding.selections encoding.rows q Finset.univ (proposalStop stopAfter)
+    (unloggedRetainedRestComputation adversary ⟨key.root, key.parameter⟩) state
+  have hvalid : MonitoredValid (gameInputs adversary) state.2 :=
+    ⟨initialAllowed_nonempty _ exposed, initialState_rowsCovered _ _ exposed⟩
+  have hinv : ProposalInvariant key fixedProposalLength state :=
+    certificateProposalInvariant_initial key fixedProposalLength 1212415 _ stopped (fun _ => le_rfl)
+  have hproject : Prod.map id Prod.snd <$> law =
+      initialMonitoredSource key adversary encoding dummy exposed high q Finset.univ (proposalStop stopAfter) stopped :=
+    proposalRun_erasure key (gameInputs adversary) (canonicalEncodingInputs_subset_retainedGameInputs adversary key.parameter)
+      (referenceFamilyWords encoding.selections dummy)
+      (coordinateGraphLabels (initialKnown (referenceFamilyWords encoding.selections dummy) exposed) high)
+      encoding.selections encoding.rows q Finset.univ (proposalStop stopAfter) _ state
+  have herase (weight : Option (Forgery × Bool) × MonitoredState (gameInputs adversary) → ENNReal) :
+      (∑' result, Pr[= result | law] * weight (Prod.map id Prod.snd result)) =
+        ∑' result, Pr[= result |
+          initialMonitoredSource key adversary encoding dummy exposed high q Finset.univ (proposalStop stopAfter) stopped] * weight result := by
+    have h := congrArg (fun p => ∑' result, Pr[= result | p] * weight result) hproject
+    rw [tsum_probOutput_map_mul] at h
+    exact h
+  have hmass : ∀ result, law result ≠ 0 → result.2.2.2.creationMass ≤ (q : ENNReal) := by
+    intro result hresult
+    have h := map_nonzero law (Prod.map id Prod.snd) result hresult
+    rw [hproject] at h
+    exact initialMonitoredSource_creationMass_le key adversary encoding dummy exposed high q Finset.univ (proposalStop stopAfter) stopped
+      hparameter hencoding hroot hq _ h
+  have hcost := expected_proposalRun_creationCost_le_mass_terminalPotential key (gameInputs adversary)
+    (canonicalEncodingInputs_subset_retainedGameInputs adversary key.parameter) (referenceFamilyWords encoding.selections dummy)
+    (coordinateGraphLabels (initialKnown (referenceFamilyWords encoding.selections dummy) exposed) high)
+    encoding.selections encoding.rows q Finset.univ stopAfter fixedProposalLength
+    (unloggedRetainedRestComputation adversary ⟨key.root, key.parameter⟩) state hvalid
+    (sourceInputs_unlogged_subset_gameInputs adversary key) hbudget hinv
+  have huniform := expected_proposalRun_terminalPotential key (gameInputs adversary)
+    (canonicalEncodingInputs_subset_retainedGameInputs adversary key.parameter) (referenceFamilyWords encoding.selections dummy)
+    (coordinateGraphLabels (initialKnown (referenceFamilyWords encoding.selections dummy) exposed) high)
+    encoding.selections encoding.rows q Finset.univ (proposalStop stopAfter)
+    (unloggedRetainedRestComputation adversary ⟨key.root, key.parameter⟩) state hvalid
+    (sourceInputs_unlogged_subset_gameInputs adversary key) fixedProposalLength
+    (fun word => terminalCertificatePrice Finset.univ word - (2 ^ 128 : ENNReal)⁻¹)
+  change (∑' result, Pr[= result | law] * terminalProposalPotential (PMF.uniformOfFintype Index) fixedProposalLength
+    (fun word => terminalCertificatePrice Finset.univ word - (2 ^ 128 : ENNReal)⁻¹) result.2.1) = _ at huniform
+  have hzero : state.2.2.creationCost = 0 := rfl
+  rw [hzero, zero_add] at hcost
+  have hempty : state.1 = [] := rfl
+  rw [hempty, terminalProposalPotential_empty] at huniform
+  calc
+    _ ≤ ∑' result, Pr[= result |
+        initialMonitoredSource key adversary encoding dummy exposed high q Finset.univ (proposalStop stopAfter) stopped] * result.2.2.creationCost :=
+      expected_initialMonitoredSource_count_le_creationCost key adversary encoding dummy exposed high q Finset.univ (proposalStop stopAfter) stopped
+    _ = ∑' result, Pr[= result | law] * result.2.2.2.creationCost := (herase (fun result => result.2.2.creationCost)).symm
+    _ ≤ ∑' result, Pr[= result | law] * (result.2.2.2.creationMass *
+        terminalProposalPotential (PMF.uniformOfFintype Index) fixedProposalLength (terminalCertificatePrice Finset.univ) result.2.1) := hcost
+    _ ≤ (2 ^ 128 : ENNReal)⁻¹ * (∑' result, Pr[= result | law] * result.2.2.2.creationMass) +
+        (q : ENNReal) * ∑' result, Pr[= result | law] * terminalProposalPotential (PMF.uniformOfFintype Index) fixedProposalLength
+          (fun word => terminalCertificatePrice Finset.univ word - (2 ^ 128 : ENNReal)⁻¹) result.2.1 :=
+      expected_weighted_terminalPotential_le law (fun result => result.2.1) (fun result => result.2.2.2.creationMass)
+        q (2 ^ 128 : ENNReal)⁻¹ hmass fixedProposalLength (terminalCertificatePrice Finset.univ)
+    _ ≤ _ := by
+      rw [huniform]
+      have hm := herase (fun result => result.2.2.creationMass)
+      dsimp only [Prod.map] at hm
+      rw [hm]
+      exact add_le_add (mul_le_mul' le_rfl
+        (expected_initialMonitoredSource_creationMass_le_messageCalls key adversary encoding dummy exposed high q Finset.univ (proposalStop stopAfter) stopped))
+        (mul_le_mul' le_rfl uniformWordAverage_full_price_excess_le)
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualTraceValidity.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualTraceValidity.lean
new file mode 100644
index 000000000..a6f2ebb27
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualTraceValidity.lean
@@ -0,0 +1,107 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Ots.PrefixEncodingRisk
+import SphincsSecurity.Proof.Residual.RetainedResidualMessageTrace
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+def TraceValid (parameter : PublicParameter) (oracle : QueryImpl HashSpec Id) (trace : SigningBoundaryTrace) : Prop :=
+  ∀ entry ∈ trace.messageCalls, FtsProbeSimulation.MessageHashInput parameter entry.1 ∧ entry.2 = oracle entry.1
+
+theorem traceValid_one (parameter : PublicParameter) (oracle : QueryImpl HashSpec Id) : TraceValid parameter oracle 1 := by
+  intro entry hentry
+  cases hentry
+
+theorem traceValid_mul (parameter : PublicParameter) (oracle : QueryImpl HashSpec Id) (left right : SigningBoundaryTrace)
+    (hleft : TraceValid parameter oracle left) (hright : TraceValid parameter oracle right) : TraceValid parameter oracle (left * right) := by
+  intro entry hentry
+  rw [SigningBoundaryTrace.messageCalls_mul, List.mem_append] at hentry
+  exact hentry.elim (hleft entry) (hright entry)
+
+theorem fixedHashWorld_traceValid (parameter : PublicParameter) (oracle : QueryImpl HashSpec Id)
+    (input : OracleWorld.Domain) (answer : OracleWorld.Range input) (hanswer : 𝒟[fixedHashWorld oracle input] answer ≠ 0) :
+    TraceValid parameter oracle (signingBoundaryTrace parameter input answer) := by
+  cases input with
+  | inl input => exact traceValid_one parameter oracle
+  | inr input =>
+      simp only [fixedHashWorld, evalDist_pure, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hanswer
+      subst answer
+      change TraceValid parameter oracle (FreeMonoid.of
+        (if FtsProbeSimulation.MessageHashInput parameter input then some (input, oracle input) else none))
+      by_cases hmessage : FtsProbeSimulation.MessageHashInput parameter input
+      · rw [if_pos hmessage]
+        intro entry hentry
+        change entry ∈ [(input, oracle input)] at hentry
+        obtain rfl := List.mem_singleton.mp hentry
+        exact ⟨hmessage, rfl⟩
+      · rw [if_neg hmessage]
+        intro entry hentry
+        cases hentry
+
+theorem fixedBoundaryRun_traceValid {Result : Type} (parameter : PublicParameter) (oracle : QueryImpl HashSpec Id)
+    (computation : OracleComp OracleWorld Result) (result : Result × SigningBoundaryTrace)
+    (hresult : 𝒟[fixedBoundaryRun parameter oracle computation] result ≠ 0) : TraceValid parameter oracle result.2 := by
+  induction computation using OracleComp.inductionOn generalizing result with
+  | pure value =>
+      simp only [fixedBoundaryRun_pure, evalDist_pure, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact traceValid_one parameter oracle
+  | query_bind input next ih =>
+      rw [ResidualByteFrontend.fixedBoundaryRun_query_bind, evalDist_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨answer, hanswer, hresult⟩ := hresult
+      rw [evalDist_map, map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨tail, htail, hresult⟩ := hresult
+      simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+      subst result
+      exact traceValid_mul parameter oracle _ _ (fixedHashWorld_traceValid parameter oracle input answer hanswer) (ih answer tail htail)
+
+theorem cacheFold_property (property : HashInput → HashOutput → Prop) (entries : List (HashInput × HashOutput))
+    (hentries : ∀ entry ∈ entries, property entry.1 entry.2) (cache : ExternalCache)
+    (hcache : ∀ input answer, cache input = some answer → property input answer) :
+    ∀ (input : HashInput) (answer : HashOutput),
+      (entries.foldl (fun (current : ExternalCache) entry => Function.update current entry.1 (some entry.2)) cache) input = some answer → property input answer := by
+  induction entries generalizing cache with
+  | nil => exact hcache
+  | cons entry entries ih =>
+      apply ih (fun item hitem => hentries item (List.mem_cons_of_mem entry hitem))
+      intro input answer h
+      change Function.update cache entry.1 (some entry.2) input = some answer at h
+      by_cases heq : input = entry.1
+      · subst input
+        simp only [Function.update_self, Option.some.injEq] at h
+        subst answer
+        exact hentries entry (List.mem_cons_self ..)
+      · rw [Function.update_of_ne heq] at h
+        exact hcache input answer h
+
+theorem applyBoundary_cacheMatches (parameter : PublicParameter) (oracle : QueryImpl HashSpec Id)
+    (memory : Memory) (trace : SigningBoundaryTrace) (htrace : TraceValid parameter oracle trace)
+    (hmatches : ResidualByteFrontend.CacheMatches oracle memory.external.cache) :
+    ResidualByteFrontend.CacheMatches oracle (memory.applyBoundary trace).external.cache :=
+  cacheFold_property (fun input answer => answer = oracle input) trace.messageCalls (fun entry hentry => (htrace entry hentry).2) memory.external.cache hmatches
+
+theorem applyBoundary_cacheClean (parameter : PublicParameter) (oracle : QueryImpl HashSpec Id)
+    (words : OtsReferenceWords) (disclosed : Index → FtsTree → FtsLeaf → Prop) (actual : Labels)
+    (memory : Memory) (trace : SigningBoundaryTrace) (htrace : TraceValid parameter oracle trace)
+    (hclean : CacheClean parameter words disclosed actual memory.external.cache) :
+    CacheClean parameter words disclosed actual (memory.applyBoundary trace).external.cache := by
+  apply cacheFold_property (fun input answer => ¬CanonicalProbeRouting.Bad parameter words disclosed actual input answer)
+    trace.messageCalls _ memory.external.cache hclean
+  rintro ⟨input, answer⟩ hentry ⟨position, hat, _⟩
+  obtain ⟨payload, heq⟩ := (htrace (input, answer) hentry).1
+  rw [← heq] at hat
+  exact (decodePosition_none_iff parameter _).mp (decodePosition_message parameter payload) position hat
+
+theorem applyBoundary_encodingClean (parameter : PublicParameter) (oracle : QueryImpl HashSpec Id)
+    (words : OtsReferenceWords) (messages : EncodingPosition → Digest) (selections : ReferenceFamily)
+    (memory : Memory) (trace : SigningBoundaryTrace) (htrace : TraceValid parameter oracle trace)
+    (hclean : ResidualByteFrontend.ReplyClean (PublicEncodingMatch.Match parameter messages words selections) memory.external.cache) :
+    ResidualByteFrontend.ReplyClean (PublicEncodingMatch.Match parameter messages words selections) (memory.applyBoundary trace).external.cache := by
+  apply cacheFold_property (fun input answer => ¬PublicEncodingMatch.Match parameter messages words selections input answer)
+    trace.messageCalls _ memory.external.cache hclean
+  rintro ⟨input, answer⟩ hentry ⟨position, hat, _⟩
+  exact ResidualByteFrontend.message_not_encoding parameter input (htrace (input, answer) hentry).1 position hat
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualVerify.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualVerify.lean
new file mode 100644
index 000000000..fd48b8659
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualVerify.lean
@@ -0,0 +1,127 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualRecovery
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+  signDigestLoop signAfterDigest sequenceFin chainWalk
+set_option backward.isDefEq.respectTransparency false
+
+theorem Context.root_value {inputs : Finset HashInput} (context : Context inputs) :
+    canonicalGraphRoot context.graph = honestNode context.oracle context.key.parameter topLayer rootTree
+      (context.key.otsSecret topLayer rootTree) (layerHeight topLayer) 0 := by
+  rw [← context.graph_eq, canonicalGraphLabels_root]
+  rfl
+
+theorem Compatible.layer_frame_reference {inputs : Finset HashInput} {context : Context inputs} {memory : Memory}
+    (hcompatible : Compatible context memory) (index : Index) (signature : Signature) (lay : Layer)
+    (message target leafValue : Digest)
+    (hword : TargetSum.Valid (context.words lay (treeIndexAt index lay) (leafIndexAt index lay)))
+    (hframe : LayerFrame context.oracle memory.external.cache context.key.parameter index signature lay message target leafValue)
+    (hfold : foldValue context.oracle context.key.parameter lay (treeIndexAt index lay) (leafIndexAt index lay)
+      (signaturePath signature lay) leafValue (layerHeight lay) =
+      honestNode context.oracle context.key.parameter lay (treeIndexAt index lay)
+        (context.key.otsSecret lay (treeIndexAt index lay)) (layerHeight lay) 0) :
+    message = evalWithAnswerFn context.oracle (layerMessage context.key index lay) ∧
+      HonestLayerOpening context.oracle context.key.parameter context.key.otsSecret lay
+        (treeIndexAt index lay) (leafIndexAt index lay) (evalWithAnswerFn context.oracle (layerMessage context.key index lay))
+        (signature.counter lay) (signature.chainValue lay) (signaturePath signature lay) ∧
+      CachedRun memory.external.cache context.oracle (otsLeaf context.key.parameter lay (treeIndexAt index lay)
+        (leafIndexAt index lay) (evalWithAnswerFn context.oracle (layerMessage context.key index lay))
+        (signature.counter lay) (signature.chainValue lay)) := by
+  have hhonest := hcompatible.layer_honest lay (treeIndexAt index lay) (leafIndexAt index lay)
+    (leafIndexAt_lt index lay) message (signature.counter lay) (signature.chainValue lay) (signaturePath signature lay)
+    leafValue hframe.1 hfold hframe.2.2.1 hframe.2.2.2.1
+  obtain ⟨_, _, hmessage, _⟩ := hcompatible.layer_reference lay (treeIndexAt index lay) (leafIndexAt index lay)
+    message (signature.counter lay) (signature.chainValue lay) (signaturePath signature lay) hword hhonest hframe.2.2.1
+  have heq := hmessage.trans (context.layer_message index lay)
+  refine ⟨heq, ?_⟩
+  rw [← heq]
+  exact ⟨hhonest, hframe.2.2.1⟩
+
+theorem Compatible.hypertree_honest {inputs : Finset HashInput} {context : Context inputs} {memory : Memory}
+    (hcompatible : Compatible context memory) (hdummy : ∀ lay tree leaf, TargetSum.Valid (context.dummy lay tree leaf))
+    (hroot : context.key.root = canonicalGraphRoot context.graph) (index : Index) (leaves : IndexGroup → FtsLeaf)
+    (signature : Signature)
+    (hverify : evalWithAnswerFn context.oracle
+      (verifyLayers context.key.parameter index signature numLayers
+        (evalWithAnswerFn context.oracle (ftsRecover context.key.parameter index leaves signature.ftsSecret signature.ftsPath))) =
+      some context.key.root)
+    (hlayersRun : CachedRun memory.external.cache context.oracle
+      (verifyLayers context.key.parameter index signature numLayers
+        (evalWithAnswerFn context.oracle (ftsRecover context.key.parameter index leaves signature.ftsSecret signature.ftsPath))))
+    (hftsRun : CachedRun memory.external.cache context.oracle
+      (ftsRecover context.key.parameter index leaves signature.ftsSecret signature.ftsPath)) :
+    FullyHonestOpening context.oracle memory.external.cache context.key index leaves signature ∧
+      ∀ tree, memory.routing.disclosed index tree (leaves (ftsIndexOf tree)) := by
+  let ftsPublicKey := evalWithAnswerFn context.oracle
+    (ftsRecover context.key.parameter index leaves signature.ftsSecret signature.ftsPath)
+  obtain ⟨bottomLeaf, hbottom, middleLeaf, hmiddle, topLeaf, htop⟩ :=
+    hypertreeRun_of_verify index signature ftsPublicKey context.key.root hverify hlayersRun
+  let middleMessage := foldValue context.oracle context.key.parameter bottomLayer
+    (treeIndexAt index bottomLayer) (leafIndexAt index bottomLayer)
+    (signaturePath signature bottomLayer) bottomLeaf (layerHeight bottomLayer)
+  let topMessage := foldValue context.oracle context.key.parameter middleLayer
+    (treeIndexAt index middleLayer) (leafIndexAt index middleLayer)
+    (signaturePath signature middleLayer) middleLeaf (layerHeight middleLayer)
+  have htopFold : foldValue context.oracle context.key.parameter topLayer
+      (treeIndexAt index topLayer) (leafIndexAt index topLayer) (signaturePath signature topLayer) topLeaf
+      (layerHeight topLayer) = context.key.root := by
+    simpa only [topLayer, verifyLayers_zero_eq, evalWithAnswerFn_pure, Option.some.injEq] using htop.2.1
+  have htree : treeIndexAt index topLayer = rootTree := Fin.ext (treeIndexAt_topLayer index)
+  have htopRoot : foldValue context.oracle context.key.parameter topLayer
+      (treeIndexAt index topLayer) (leafIndexAt index topLayer) (signaturePath signature topLayer) topLeaf
+      (layerHeight topLayer) = honestNode context.oracle context.key.parameter topLayer (treeIndexAt index topLayer)
+        (context.key.otsSecret topLayer (treeIndexAt index topLayer)) (layerHeight topLayer) 0 := by
+    rw [htopFold, hroot, context.root_value, htree]
+  have htopOpening := hcompatible.layer_frame_reference index signature topLayer topMessage context.key.root topLeaf
+    (context.words_valid hdummy _ _ _) htop htopRoot
+  have hmiddleRoot := exact_top_message_eq_middle_root context.oracle context.key index index topMessage
+    rfl rfl htopOpening.1.symm
+  have hmiddleOpening := hcompatible.layer_frame_reference index signature middleLayer middleMessage context.key.root middleLeaf
+    (context.words_valid hdummy _ _ _) hmiddle hmiddleRoot
+  have hbottomRoot := exact_middle_message_eq_bottom_root context.oracle context.key index index middleMessage
+    rfl rfl hmiddleOpening.1.symm
+  have hbottomOpening := hcompatible.layer_frame_reference index signature bottomLayer ftsPublicKey context.key.root bottomLeaf
+    (context.words_valid hdummy _ _ _) hbottom hbottomRoot
+  have hftsKey := exact_bottom_message_eq_fts_key context.oracle context.key index index ftsPublicKey
+    rfl rfl hbottomOpening.1.symm
+  have hftsHonest := hcompatible.ftsRecover_honest index leaves signature.ftsSecret signature.ftsPath hftsKey hftsRun
+  refine ⟨⟨?_, hftsHonest, hftsRun, ?_⟩,
+    hcompatible.ftsRecover_disclosed index leaves signature.ftsSecret signature.ftsPath hftsKey hftsRun⟩
+  · intro lay
+    fin_cases lay
+    · simpa only [topLayer] using htopOpening.2
+    · simpa only [middleLayer] using hmiddleOpening.2
+    · simpa only [bottomLayer, numLayers] using hbottomOpening.2
+  · intro lay
+    have hverifier (position : Layer) (message : Digest)
+        (hposition : position = bottomLayer ∧ message = ftsPublicKey ∨
+          position = middleLayer ∧ message = middleMessage ∨ position = topLayer ∧ message = topMessage) :
+        VerifierLayerMessage context.oracle context.key.parameter index leaves signature position message :=
+      ⟨bottomLeaf, hbottom.1, middleLeaf, hmiddle.1, hposition⟩
+    fin_cases lay
+    · rw [show (⟨0, by decide⟩ : Layer) = topLayer from rfl, ← htopOpening.1]
+      exact hverifier _ _ (Or.inr (Or.inr ⟨rfl, rfl⟩))
+    · rw [show (⟨1, by decide⟩ : Layer) = middleLayer from rfl, ← hmiddleOpening.1]
+      exact hverifier _ _ (Or.inr (Or.inl ⟨rfl, rfl⟩))
+    · rw [show (⟨2, by decide⟩ : Layer) = bottomLayer from rfl, ← hbottomOpening.1]
+      exact hverifier _ _ (Or.inl ⟨rfl, rfl⟩)
+
+theorem Compatible.verify_honest {inputs : Finset HashInput} {context : Context inputs} {memory : Memory}
+    (hcompatible : Compatible context memory) (hdummy : ∀ lay tree leaf, TargetSum.Valid (context.dummy lay tree leaf))
+    (hroot : context.key.root = canonicalGraphRoot context.graph) (message : Message) (signature : Signature)
+    (hverify : evalWithAnswerFn context.oracle (verify ⟨context.key.root, context.key.parameter⟩ message signature) = true)
+    (hrun : CachedRun memory.external.cache context.oracle (verify ⟨context.key.root, context.key.parameter⟩ message signature)) :
+    ∃ digest, evalWithAnswerFn context.oracle (messageDigest context.key.parameter context.key.root message signature.randomness) = digest ∧
+      CachedRun memory.external.cache context.oracle (messageDigest context.key.parameter context.key.root message signature.randomness) ∧
+      Admissible digest ∧
+      FullyHonestOpening context.oracle memory.external.cache context.key (digestIndex digest) (digestLeaves digest) signature ∧
+      ∀ tree, memory.routing.disclosed (digestIndex digest) tree (digestLeaves digest (ftsIndexOf tree)) := by
+  obtain ⟨digest, hdigest, hdigestRun, hadmissible, hlayers, hftsRun, hlayersRun⟩ :=
+    verify_extract ⟨context.key.root, context.key.parameter⟩ message signature hverify hrun
+  exact ⟨digest, hdigest, hdigestRun, hadmissible,
+    hcompatible.hypertree_honest hdummy hroot (digestIndex digest) (digestLeaves digest) signature hlayers hlayersRun hftsRun⟩
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualVerifySupport.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualVerifySupport.lean
new file mode 100644
index 000000000..5cf6e4c7b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualVerifySupport.lean
@@ -0,0 +1,154 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FtsProbeVerifierSource
+import SphincsSecurity.Proof.Residual.RetainedResidualSuccessTransfer
+import SphincsSecurity.Proof.Residual.RetainedResidualVerify
+
+/-! ## RetainedResidualWorld -/
+
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open InterleavedResidual (Routing)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs sourceInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+set_option backward.isDefEq.respectTransparency false
+
+theorem fixedSourceRun_bind {A B : Type} {inputs : Finset HashInput} (context : Context inputs)
+    (computation : OracleComp (OracleWorld + SigningSpec) A)
+    (next : A → OracleComp (OracleWorld + SigningSpec) B) (memory : Memory) :
+    fixedSourceRun context (computation >>= next) memory =
+      (fixedSourceRun context computation memory >>= fun result =>
+        result.1.elim (pure (none, result.2)) (fun value => fixedSourceRun context (next value) result.2)) := by
+  simp only [fixedSourceRun, simulateQ_bind, OptionT.run_bind, Option.elimM, StateT.run_bind]
+  apply congrArg (_ >>= ·)
+  funext result
+  rcases result with ⟨value, after⟩
+  cases value <;> rfl
+
+end SphincsSecurity.Concrete.RetainedResidual
+
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open FtsProbeSimulation (liftHashSource)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] hashInputs sourceInputs canonicalEncodingInputs canonicalGraphInputs instFintypePosition
+  signDigestLoop signAfterDigest sequenceFin chainWalk
+set_option backward.isDefEq.respectTransparency false
+
+theorem fixedHashStep_cache {inputs : Finset HashInput} (context : Context inputs) (input : HashInput)
+    (memory : Memory) (answer : HashOutput)
+    (hlive : (fixedHashStep context.key.parameter context.words context.auxiliary.selections memory.routing
+      context.actual context.oracle input memory).1 = some answer) :
+    (fixedHashStep context.key.parameter context.words context.auxiliary.selections memory.routing
+      context.actual context.oracle input memory).2.external.cache =
+      Function.update memory.external.cache input (some (context.oracle input)) := by
+  rw [fixedHashStep_external]
+  unfold fixedHashStep ResidualByteFrontend.fixedStep ResidualByteFrontend.fixedAnswer ResidualByteFrontend.checkedResult at hlive
+  unfold ResidualByteFrontend.fixedStep ResidualByteFrontend.fixedAnswer
+  split
+  · rename_i hbad
+    simp only [if_pos hbad, Option.bind_none, reduceCtorEq] at hlive
+  · rfl
+
+theorem fixedSourceRun_hash_success {Result : Type} {inputs : Finset HashInput} (context : Context inputs)
+    (computation : OracleComp HashSpec Result) (memory : Memory) (value : Result) (after : Memory)
+    (hresult : fixedSourceRun context (liftHashSource computation) memory (some value, after) ≠ 0) :
+    value = evalWithAnswerFn context.oracle computation ∧ CachedRun after.external.cache context.oracle computation ∧
+      ∀ input, memory.external.cache input ≠ none → after.external.cache input ≠ none := by
+  induction computation using OracleComp.inductionOn generalizing memory value after with
+  | pure value =>
+      simp only [liftHashSource, simulateQ_pure, fixedSourceRun_pure, ne_eq, SPMF.pure_apply_eq_zero_iff,
+        not_not, Prod.mk.injEq, Option.some.injEq] at hresult
+      obtain ⟨rfl, rfl⟩ := hresult
+      exact ⟨rfl, CachedRun.pure _ _ _, fun _ h => h⟩
+  | query_bind input next ih =>
+      rw [FtsProbeSimulation.liftHashSource_query_bind, fixedSourceRun_query_bind] at hresult
+      simp only [fixedSourceImpl, OptionT.run_mk, StateT.run_mk, fixedByteRun, simulateQ_spec_query,
+        fixedByteImpl, pure_bind] at hresult
+      generalize hstep : fixedHashStep context.key.parameter context.words context.auxiliary.selections memory.routing
+        context.actual context.oracle input memory = step at hresult
+      rcases step with ⟨answer, middle⟩
+      cases answer with
+      | none =>
+          simp only [Option.elim_none, ne_eq, SPMF.pure_apply_eq_zero_iff, Prod.mk.injEq, Option.some_ne_none,
+            false_and, not_not] at hresult
+      | some answer =>
+          have hanswer : answer = context.oracle input := by
+            rcases fixedHashStep_answer context input memory with hstop | hlive
+            · rw [hstep] at hstop
+              cases hstop
+            · rw [hstep] at hlive
+              exact Option.some.inj hlive
+          subst answer
+          have hcache : middle.external.cache = Function.update memory.external.cache input (some (context.oracle input)) := by
+            have h := fixedHashStep_cache context input memory (context.oracle input) (by rw [hstep])
+            simpa only [hstep] using h
+          obtain ⟨hvalue, hcached, hpreserves⟩ := ih (context.oracle input) middle value after hresult
+          refine ⟨hvalue, ?_, ?_⟩
+          · intro other hother
+            rw [queriedInputs_query_bind, List.mem_cons] at hother
+            rcases hother with rfl | hother
+            · apply hpreserves
+              rw [hcache, Function.update_self]
+              simp only [ne_eq, reduceCtorEq, not_false_eq_true]
+            · exact hcached _ hother
+          · intro other hother
+            apply hpreserves
+            rw [hcache]
+            by_cases heq : other = input
+            · rw [heq, Function.update_self]
+              simp only [ne_eq, reduceCtorEq, not_false_eq_true]
+            · rwa [Function.update_of_ne heq]
+
+theorem fixedSourceRun_verify_honest {inputs : Finset HashInput} (context : Context inputs)
+    (memory : Memory) (hcompatible : Compatible context memory)
+    (hdummy : ∀ lay tree leaf, TargetSum.Valid (context.dummy lay tree leaf))
+    (hroot : context.key.root = canonicalGraphRoot context.graph) (message : Message) (signature : Signature) (after : Memory)
+    (hresult : fixedSourceRun context
+      (FtsProbeSimulation.liftOracleWorldLeft (scheme.verify ⟨context.key.root, context.key.parameter⟩ message signature))
+        memory (some true, after) ≠ 0) :
+    ∃ digest, evalWithAnswerFn context.oracle (messageDigest context.key.parameter context.key.root message signature.randomness) = digest ∧
+      CachedRun after.external.cache context.oracle (messageDigest context.key.parameter context.key.root message signature.randomness) ∧
+      Admissible digest ∧ FullyHonestOpening context.oracle after.external.cache context.key (digestIndex digest) (digestLeaves digest) signature ∧
+      ∀ tree, after.routing.disclosed (digestIndex digest) tree (digestLeaves digest (ftsIndexOf tree)) := by
+  have hcompatible' := fixedSourceRun_compatible context _ memory hcompatible true after hresult
+  rw [FtsProbeSimulation.liftOracleWorldLeft_scheme_verify] at hresult
+  obtain ⟨hvalue, hcached, _⟩ := fixedSourceRun_hash_success context _ memory true after hresult
+  exact hcompatible'.verify_honest hdummy hroot message signature hvalue.symm hcached
+
+theorem fixedSourceRun_rest_honest {inputs : Finset HashInput} (context : Context inputs)
+    (memory : Memory) (hcompatible : Compatible context memory)
+    (hdummy : ∀ lay tree leaf, TargetSum.Valid (context.dummy lay tree leaf))
+    (hroot : context.key.root = canonicalGraphRoot context.graph) (adversary : Adversary) (forgery : Forgery) (after : Memory)
+    (hresult : fixedSourceRun context
+      (FtsProbeSimulation.unloggedRetainedRestComputation adversary ⟨context.key.root, context.key.parameter⟩)
+        memory (some (forgery, true), after) ≠ 0) :
+    ∃ digest, evalWithAnswerFn context.oracle (messageDigest context.key.parameter context.key.root forgery.message forgery.signature.randomness) = digest ∧
+      CachedRun after.external.cache context.oracle
+        (messageDigest context.key.parameter context.key.root forgery.message forgery.signature.randomness) ∧
+      Admissible digest ∧ FullyHonestOpening context.oracle after.external.cache context.key (digestIndex digest) (digestLeaves digest) forgery.signature ∧
+      ∀ tree, after.routing.disclosed (digestIndex digest) tree (digestLeaves digest (ftsIndexOf tree)) := by
+  rw [FtsProbeSimulation.unloggedRetainedRestComputation, fixedSourceRun_bind, RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨⟨candidate, middle⟩, hmiddle, hresult⟩ := hresult
+  cases candidate with
+  | none =>
+      simp only [Option.elim_none, ne_eq, SPMF.pure_apply_eq_zero_iff, Prod.mk.injEq,
+        Option.some_ne_none, false_and, not_not] at hresult
+  | some candidate =>
+      have hcompatible' := fixedSourceRun_compatible context _ memory hcompatible candidate middle hmiddle
+      simp only [Option.elim_some] at hresult
+      rw [fixedSourceRun_bind, RetainedObservation.bind_nonzero] at hresult
+      obtain ⟨⟨checked, finalMemory⟩, hchecked, hresult⟩ := hresult
+      cases checked with
+      | none =>
+          simp only [Option.elim_none, ne_eq, SPMF.pure_apply_eq_zero_iff, Prod.mk.injEq,
+            Option.some_ne_none, false_and, not_not] at hresult
+      | some checked =>
+          simp only [Option.elim_some, fixedSourceRun_pure, ne_eq, SPMF.pure_apply_eq_zero_iff,
+            not_not, Prod.mk.injEq, Option.some.injEq] at hresult
+          obtain ⟨⟨rfl, rfl⟩, rfl⟩ := hresult
+          exact fixedSourceRun_verify_honest context middle hcompatible' hdummy hroot _ _ _ hchecked
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualWorkCost.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualWorkCost.lean
new file mode 100644
index 000000000..c46e9095d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualWorkCost.lean
@@ -0,0 +1,91 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualSigningLaw
+import SphincsSecurity.Proof.Reference.SigningBoundaryHashCost
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec ENNReal CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing SigningRecord)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs
+  signDigestLoop publicSignPlan
+set_option backward.isDefEq.respectTransparency false
+
+theorem boundaryRun_signDigestLoop_exhaustion (parameter : PublicParameter) (key : SecretKey) (message : Message)
+    (attempts : Nat) (cache : QueryCache HashSpec)
+    (result : (Option (Randomness × Index × (IndexGroup → FtsLeaf)) × SigningBoundaryTrace) × QueryCache HashSpec)
+    (hr : result ∈ support (boundaryRun parameter (signDigestLoop attempts key message) cache))
+    (hn : result.1.1 = none) : attempts ≤ result.1.2.hashCalls := by
+  induction attempts generalizing cache result with
+  | zero => exact Nat.zero_le _
+  | succ attempts ih =>
+      rw [signDigestLoop, boundaryRun_bind, mem_support_bind_iff] at hr
+      obtain ⟨sample, _, hr⟩ := hr
+      rw [support_map] at hr
+      obtain ⟨last, hlast, rfl⟩ := hr
+      rw [boundaryRun_bind, mem_support_bind_iff] at hlast
+      obtain ⟨attempt, hattempt, hlast⟩ := hlast
+      rw [support_map] at hlast
+      obtain ⟨tail, htail, rfl⟩ := hlast
+      have hcost := boundaryHashAtLeast_signAttempt parameter key message sample.1.1 sample.2 attempt hattempt
+      change tail.1.1 = none at hn
+      cases hat : attempt.1.1 with
+      | none =>
+          simp only [hat] at htail
+          have h := ih attempt.2 tail htail hn
+          simp only [SigningBoundaryTrace.hashCalls_mul]
+          omega
+      | some selected =>
+          simp only [hat, boundaryRun, simulateQ_pure, WriterT.run_pure, StateT.run_pure,
+            support_pure, Set.mem_singleton_iff] at htail
+          subst tail
+          cases hn
+
+theorem publicSigningWork_hashCalls_min (key : SecretKey) (known : Labels) (words : OtsReferenceWords)
+    (selections : ReferenceFamily) (message : Message) (cache : QueryCache HashSpec)
+    (result : (PublicSigningRecord × Nat) × QueryCache HashSpec)
+    (hr : result ∈ support ((simulateQ romImpl
+      (ResidualByteFrontend.publicSigningWork key.parameter key.root known words selections message)).run cache)) :
+    28504 ≤ result.1.1.2.hashCalls := by
+  rw [publicSigningWork_eq_digestWork, simulateQ_map, StateT.run_map, support_map] at hr
+  obtain ⟨loop, hloop, rfl⟩ := hr
+  rw [publicDigestLoop_eq, simulateQ_boundaryComputation] at hloop
+  change loop ∈ support (boundaryRun key.parameter (signDigestLoop digestAttemptLimit key message) cache) at hloop
+  cases hs : loop.1.1 with
+  | none =>
+      have hc := boundaryRun_signDigestLoop_exhaustion key.parameter key message digestAttemptLimit cache loop hloop hs
+      simp only [digestWork, hs]
+      exact (show 28504 ≤ digestAttemptLimit by decide).trans hc
+  | some selected =>
+      simp only [digestWork, hs, SigningBoundaryTrace.hashCalls_mul, SigningBoundaryTrace.hashCalls_pow_none]
+      unfold publicSignPlan
+      dsimp only
+      omega
+
+variable (key : SecretKey) (inputs : Finset HashInput) (hencoding : canonicalEncodingInputs key.parameter ⊆ inputs)
+  (words : OtsReferenceWords) (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+attribute [local irreducible] lazyRun environment ResidualByteFrontend.jointSigningProgram
+
+theorem lazyRun_jointSigningProgram_hashCalls_min (routing : Routing) (message : Message)
+    (hinputs : hashInputs (signDigestLoop digestAttemptLimit key message) ⊆ inputs) (state : State inputs)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (result : Option SigningRecord × State inputs)
+    (hresult : lazyRun (environment key.parameter inputs hencoding words publicReplies selections rows)
+      (simulateQ (embed inputs routing)
+        (ResidualByteFrontend.jointSigningProgram inputs key.parameter key.root routing.known words selections message)) state result ≠ 0) :
+    ∃ record, result.1 = some record ∧ 28504 ≤ record.2.hashCalls := by
+  have h := map_nonzero _ cacheResult result hresult
+  rw [lazyRun_jointSigningProgram_cache key.parameter inputs hencoding words publicReplies selections rows routing key.root message
+    (by simpa only [publicDigestLoop_eq] using hinputs) state ha hcovered, RetainedObservation.bind_nonzero] at h
+  obtain ⟨actual, _, h⟩ := h
+  rw [map_eq_bind_pure_comp, RetainedObservation.bind_nonzero] at h
+  obtain ⟨work, hwork, h⟩ := h
+  simp only [Function.comp_def, ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at h
+  refine ⟨_, congrArg Prod.fst h, ?_⟩
+  rw [completePublicSigningRecord_trace]
+  exact publicSigningWork_hashCalls_min key routing.known words selections message state.memory.external.cache work
+    ((mem_support_iff _ _).mpr hwork)
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualWorldCoverage.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualWorldCoverage.lean
new file mode 100644
index 000000000..b7499c37e
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualWorldCoverage.lean
@@ -0,0 +1,182 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.MessageCertificateProjection
+import SphincsSecurity.Proof.Residual.RetainedResidualWorldKernel
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec ENNReal CanonicalProbeRouting
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing)
+open FtsProbeSimulation (messageAnswers MessageHashInput)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs
+set_option backward.isDefEq.respectTransparency false
+
+noncomputable def proposalOfWorldResult (parameter : PublicParameter) (input : OracleWorld.Domain)
+    (result : OracleWorld.Range input × QueryCache HashSpec) : ProposalExecutionRecord (.inl input) :=
+  ⟨result.1, result.2, signingBoundaryTrace parameter input result.1, none, 0⟩
+
+noncomputable def worldMonitorValue (key : SecretKey) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : CertificateStopRule) (input : OracleWorld.Domain) (monitor : CertificateMonitorState)
+    (length : Nat) (result : Option (OracleWorld.Range input) × QueryCache HashSpec) : ENNReal :=
+  result.1.elim (certificateBankCount monitor.2.bank) fun answer =>
+    certificateMonitorPotential key budget required
+      (originalProposalAdvance (certificateMonitorUpdate key budget required stopAfter) (.inl input) monitor length
+        (proposalOfWorldResult key.parameter input (answer, result.2)))
+
+theorem worldMonitorValue_le_of_messageHistory (key : SecretKey) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : CertificateStopRule) (input : OracleWorld.Domain) (monitor : CertificateMonitorState)
+    (length : Nat) (result : Option (OracleWorld.Range input) × QueryCache HashSpec)
+    (hcache : messageAnswers key.parameter result.2 = messageAnswers key.parameter monitor.1) :
+    worldMonitorValue key budget required stopAfter input monitor length result ≤ certificateMonitorPotential key budget required monitor := by
+  rcases result with ⟨answer, cache⟩
+  cases answer with
+  | none => exact certificateBankCount_le_bankedCacheWeight _ _ _ _ _
+  | some answer =>
+      by_cases hactive : CertificateMonitorActive key budget (.inl input) monitor
+      · simp only [worldMonitorValue, Option.elim_some,
+          certificateMonitorPotential_advance_active key budget required stopAfter (.inl input) monitor _ _ hactive,
+          signingLogFragment, List.append_nil]
+        have h := bankedProposalRecordValue_world_le_of_messageHistory key nearUniformDigestReuseWeight
+          (budget - monitor.2.spent) (signatureLimit - monitor.2.log.length) required (certificateMonitorCoverState monitor)
+          monitor.2.bank input (proposalOfWorldResult key.parameter input (answer, cache))
+          (certificateMonitorUpdate key budget required stopAfter (.inl input) monitor length
+            (proposalOfWorldResult key.parameter input (answer, cache))).stopped hcache
+        simpa only [certificateMonitorPotential, hactive.1] using h
+      · simp only [worldMonitorValue, Option.elim_some,
+          certificateMonitorPotential_advance_inactive key budget required stopAfter (.inl input) monitor _ _ hactive]
+        exact certificateBankCount_le_bankedCacheWeight _ _ _ _ _
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+  (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem expected_lazyWorld_nonmessage_certificateMonitor_le (routing : Routing)
+    (key : SecretKey) (hparameter : key.parameter = parameter) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : CertificateStopRule) (input : HashInput) (hin : input ∈ inputs)
+    (hmessage : ¬MessageHashInput parameter input) (monitor : CertificateMonitorState)
+    (length : Option HashOutput × State inputs → Nat) (state : State inputs)
+    (hcache : state.memory.external.cache = monitor.1)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) :
+    (∑' result, Pr[= result | lazyByteRun parameter inputs hencoding words publicReplies selections rows routing
+        (liftM (OracleWorld.query (.inr input))) state] *
+      worldMonitorValue key budget required stopAfter (.inr input) monitor (length result) (cacheResult result)) ≤
+      certificateMonitorPotential key budget required monitor := by
+  calc
+    _ ≤ ∑' result, Pr[= result | lazyByteRun parameter inputs hencoding words publicReplies selections rows routing
+        (liftM (OracleWorld.query (.inr input))) state] * certificateMonitorPotential key budget required monitor := by
+      apply ENNReal.tsum_le_tsum
+      intro result
+      by_cases hr : Pr[= result | lazyByteRun parameter inputs hencoding words publicReplies selections rows routing
+          (liftM (OracleWorld.query (.inr input))) state] = 0
+      · simp only [hr, zero_mul, le_refl]
+      · apply mul_le_mul' le_rfl
+        apply worldMonitorValue_le_of_messageHistory
+        have h := lazyByteRun_hash_nonmessage parameter inputs hencoding words publicReplies selections rows routing
+          input hin state ha hcovered hmessage result hr
+        simpa only [cacheResult, hparameter, hcache] using h
+    _ ≤ _ := by
+      rw [ENNReal.tsum_mul_right]
+      exact mul_le_of_le_one_left' tsum_probOutput_le_one
+
+theorem expected_lazyWorld_message_certificateMonitor_le (routing : Routing)
+    (key : SecretKey) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : CertificateStopRule) (input : OracleWorld.Domain)
+    (hinputs : hashInputs (liftM (OracleWorld.query input)) ⊆ inputs)
+    (hmessage : ∀ hash, input = .inr hash → MessageHashInput parameter hash)
+    (monitor : CertificateMonitorState) (length : Option (OracleWorld.Range input) × State inputs → Nat)
+    (state : State inputs) (hcache : state.memory.external.cache = monitor.1)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) :
+    (∑' result, Pr[= result | lazyByteRun parameter inputs hencoding words publicReplies selections rows routing
+        (liftM (OracleWorld.query input)) state] *
+      worldMonitorValue key budget required stopAfter input monitor (length result) (cacheResult result)) ≤
+      certificateMonitorPotential key budget required monitor + certificateMonitorCharge key budget required (.inl input) monitor := by
+  by_cases hactive : CertificateMonitorActive key budget (.inl input) monitor
+  · let weight : Option (OracleWorld.Range input) × QueryCache HashSpec → ENNReal := fun result =>
+      result.1.elim (certificateBankCount monitor.2.bank) fun answer =>
+        bankedProposalRecordValue key nearUniformDigestReuseWeight (budget - monitor.2.spent)
+          (signatureLimit - monitor.2.log.length) required (certificateMonitorCoverState monitor) monitor.2.bank (.inl input)
+          (proposalOfWorldResult key.parameter input (answer, result.2)) false
+    have hkernel := congrArg (fun law : SPMF (Option (OracleWorld.Range input) × QueryCache HashSpec) =>
+      ∑' result, Pr[= result | law] * weight result)
+      (lazyByteRun_world_message_rom parameter inputs hencoding words publicReplies selections rows routing input hinputs hmessage state hcovered)
+    rw [tsum_probOutput_map_mul, tsum_probOutput_map_mul] at hkernel
+    simp only [Prod.map_fst, Prod.map_snd, id_eq, weight, Option.elim_some, hcache] at hkernel
+    have hbound := expected_originalProposalRecord_world_banked_le key nearUniformDigestReuseWeight
+      (budget - monitor.2.spent) (signatureLimit - monitor.2.log.length) required (certificateMonitorCoverState monitor)
+      monitor.2.bank input (fun _ => false) hactive.2.1.1
+      (by cases input <;> exact hactive.2.2.2)
+    calc
+      _ ≤ ∑' result, Pr[= result | lazyByteRun parameter inputs hencoding words publicReplies selections rows routing
+          (liftM (OracleWorld.query input)) state] * weight (cacheResult result) := by
+        apply ENNReal.tsum_le_tsum
+        intro result
+        apply mul_le_mul' le_rfl
+        cases hanswer : result.1 with
+        | none => simp only [worldMonitorValue, cacheResult, hanswer, Option.elim_none, weight, le_refl]
+        | some answer =>
+            simp only [worldMonitorValue, cacheResult, hanswer, Option.elim_some, weight,
+              certificateMonitorPotential_advance_active key budget required stopAfter (.inl input) monitor _ _ hactive,
+              signingLogFragment, List.append_nil]
+            exact bankedCacheWeight_discard_le _ _ _ _ _
+      _ = ∑' record, Pr[= record | originalProposalRecord key (.inl input) monitor.1] *
+          bankedProposalRecordValue key nearUniformDigestReuseWeight (budget - monitor.2.spent)
+            (signatureLimit - monitor.2.log.length) required (certificateMonitorCoverState monitor) monitor.2.bank
+            (.inl input) record false := by
+        rw [hkernel, originalProposalRecord, ← PMF.monad_map_eq_map, tsum_probOutput_map_mul]
+        rfl
+      _ ≤ _ := by
+        simpa only [certificateMonitorPotential, certificateMonitorCoverState, hactive.1, certificateMonitorCharge, if_pos hactive] using hbound
+  · simp only [worldMonitorValue, certificateMonitorCharge, if_neg hactive, add_zero,
+      certificateMonitorPotential_advance_inactive key budget required stopAfter (.inl input) monitor _ _ hactive]
+    have hconstant (result : Option (OracleWorld.Range input) × State inputs) :
+        (cacheResult result).1.elim (certificateBankCount monitor.2.bank)
+          (fun _ => certificateBankCount monitor.2.bank) = certificateBankCount monitor.2.bank := by
+      unfold cacheResult
+      cases result.1 <;> rfl
+    simp only [hconstant, ENNReal.tsum_mul_right]
+    exact (mul_le_of_le_one_left' tsum_probOutput_le_one).trans (certificateBankCount_le_bankedCacheWeight _ _ _ _ _)
+
+theorem expected_lazyWorld_certificateMonitor_le (routing : Routing)
+    (key : SecretKey) (hparameter : key.parameter = parameter) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : CertificateStopRule) (input : OracleWorld.Domain)
+    (hinputs : hashInputs (liftM (OracleWorld.query input)) ⊆ inputs)
+    (monitor : CertificateMonitorState) (length : Option (OracleWorld.Range input) × State inputs → Nat)
+    (state : State inputs) (hcache : state.memory.external.cache = monitor.1)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) :
+    (∑' result, Pr[= result | lazyByteRun parameter inputs hencoding words publicReplies selections rows routing
+        (liftM (OracleWorld.query input)) state] *
+      worldMonitorValue key budget required stopAfter input monitor (length result) (cacheResult result)) ≤
+      certificateMonitorPotential key budget required monitor + certificateMonitorCharge key budget required (.inl input) monitor := by
+  cases input with
+  | inl sample =>
+      exact expected_lazyWorld_message_certificateMonitor_le parameter inputs hencoding words publicReplies selections rows routing
+        key budget required stopAfter (.inl sample) hinputs (by intro hash heq; cases heq) monitor length state hcache hcovered
+  | inr hash =>
+      by_cases hmessage : MessageHashInput parameter hash
+      · exact expected_lazyWorld_message_certificateMonitor_le parameter inputs hencoding words publicReplies selections rows routing
+          key budget required stopAfter (.inr hash) hinputs
+          (by intro other heq; cases heq; exact hmessage) monitor length state hcache hcovered
+      · have hin : hash ∈ inputs := hinputs (by
+          simpa only [bind_pure] using mem_hashInputs_hash_bind hash pure)
+        exact (expected_lazyWorld_nonmessage_certificateMonitor_le parameter inputs hencoding words publicReplies selections rows routing
+          key hparameter budget required stopAfter hash hin hmessage monitor length state hcache ha hcovered).trans le_self_add
+
+theorem expected_externalProgram_certificateMonitor_le
+    (key : SecretKey) (hparameter : key.parameter = parameter) (budget : Nat) (required : Finset FtsTree)
+    (stopAfter : CertificateStopRule) (input : OracleWorld.Domain)
+    (hinputs : hashInputs (liftM (OracleWorld.query input)) ⊆ inputs)
+    (monitor : CertificateMonitorState) (length : Option (OracleWorld.Range input) × State inputs → Nat)
+    (state : State inputs) (hcache : state.memory.external.cache = monitor.1)
+    (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) :
+    (∑' result, Pr[= result | lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+        (externalProgram inputs parameter words selections (liftM (OracleWorld.query input))) state] *
+      worldMonitorValue key budget required stopAfter input monitor (length result) (cacheResult result)) ≤
+      certificateMonitorPotential key budget required monitor + certificateMonitorCharge key budget required (.inl input) monitor := by
+  rw [lazyRun_externalProgram]
+  exact expected_lazyWorld_certificateMonitor_le parameter inputs hencoding words publicReplies selections rows state.memory.routing
+    key hparameter budget required stopAfter input hinputs monitor length state hcache ha hcovered
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualWorldKernel.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualWorldKernel.lean
new file mode 100644
index 000000000..580786d28
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedResidualWorldKernel.lean
@@ -0,0 +1,104 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Residual.RetainedResidualCheckedTrace
+import SphincsSecurity.Proof.Residual.RetainedResidualDigestLaw
+import SphincsSecurity.Proof.Residual.RetainedResidualProgram
+namespace SphincsSecurity.Concrete.RetainedResidual
+
+open _root_.OracleComp OracleSpec CanonicalProbeRouting ResidualByteAction
+open AdaptiveResidualLabels hiding World State Environment
+open InterleavedResidual (Routing)
+open FtsProbeSimulation (messageAnswers MessageHashInput)
+attribute [local instance] Classical.propDecidable
+attribute [local irreducible] canonicalEncodingInputs canonicalGraphInputs instFintypePosition hashInputs
+set_option backward.isDefEq.respectTransparency false
+
+variable (parameter : PublicParameter) (inputs : Finset HashInput)
+  (hencoding : canonicalEncodingInputs parameter ⊆ inputs) (words : OtsReferenceWords)
+  (publicReplies : CanonicalGraphLabels) (selections : ReferenceFamily) (rows : CanonicalEncodingRows)
+
+theorem checkedHashResult_cache_of_ne (routing : Routing) (actual : Labels) (seed : inputs → HashOutput)
+    (input : inputs) (state : State inputs) (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (other : HashInput) (hne : other ≠ input.val) :
+    (checkedHashResult parameter inputs hencoding words publicReplies selections rows routing actual seed input state).2.memory.external.cache other =
+      state.memory.external.cache other := by
+  have hp := congrArg (fun result : Option HashOutput × ResidualByteFrontend.State inputs => result.2.memory.cache other)
+    (hashResult_project parameter inputs hencoding words publicReplies selections rows routing actual seed input state)
+  have hr := congrArg (fun result : Option HashOutput × ExternalMemory => result.2.cache other)
+    (ResidualByteFrontend.hashQueryResult_project parameter inputs words routing.disclosed routing.known
+      (freshPrefix parameter inputs hencoding words routing.disclosed routing.known publicReplies selections rows)
+      actual seed input (project state) hcovered
+      (freshPrefix_local parameter inputs hencoding words routing.disclosed routing.known publicReplies selections rows input))
+  change (hashResult parameter inputs hencoding words publicReplies selections rows routing actual seed input state).2.memory.external.cache other = _
+  apply hp.trans
+  apply hr.trans
+  generalize ResidualByteFrontend.publicCachedReply inputs
+    (freshPrefix parameter inputs hencoding words routing.disclosed routing.known publicReplies selections rows)
+    actual seed input (project state).memory = answer
+  cases answer <;> simp only [ResidualByteFrontend.delivered, Option.elim_none, Option.elim_some,
+    charge, storeReply, Function.update_of_ne hne, project]
+
+theorem checkedHashResult_nonmessage (routing : Routing) (actual : Labels) (seed : inputs → HashOutput)
+    (input : inputs) (state : State inputs) (hcovered : ResidualByteFrontend.RowsCovered inputs (project state))
+    (hmessage : ¬MessageHashInput parameter input.val) :
+    messageAnswers parameter
+      (checkedHashResult parameter inputs hencoding words publicReplies selections rows routing actual seed input state).2.memory.external.cache =
+      messageAnswers parameter state.memory.external.cache := by
+  funext payload
+  apply checkedHashResult_cache_of_ne parameter inputs hencoding words publicReplies selections rows routing actual seed input state hcovered
+  intro heq
+  exact hmessage ⟨payload, heq⟩
+
+theorem lazyByteRun_hash_nonmessage (routing : Routing) (input : HashInput) (hin : input ∈ inputs)
+    (state : State inputs) (ha : ∀ coordinate, (state.candidates coordinate).Nonempty)
+    (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) (hmessage : ¬MessageHashInput parameter input)
+    (result : Option HashOutput × State inputs)
+    (hresult : lazyByteRun parameter inputs hencoding words publicReplies selections rows routing
+      (liftM (OracleWorld.query (.inr input))) state result ≠ 0) :
+    messageAnswers parameter result.2.memory.external.cache = messageAnswers parameter state.memory.external.cache := by
+  unfold lazyByteRun at hresult
+  rw [← run_erasure _ _ state ha, RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨actual, _, hresult⟩ := hresult
+  rw [RetainedObservation.bind_nonzero] at hresult
+  obtain ⟨seed, _, hresult⟩ := hresult
+  simp only [simulateQ_spec_query, ResidualByteFrontend.checkedTranslate, dif_pos hin] at hresult
+  rw [observedRun_checkedHashQuery parameter inputs hencoding words publicReplies selections rows routing actual seed
+    ⟨input, hin⟩ state] at hresult
+  simp only [ne_eq, SPMF.pure_apply_eq_zero_iff, not_not] at hresult
+  subst result
+  exact checkedHashResult_nonmessage parameter inputs hencoding words publicReplies selections rows routing actual seed
+    ⟨input, hin⟩ state hcovered hmessage
+
+theorem lazyByteRun_world_message_rom (routing : Routing) (input : OracleWorld.Domain)
+    (hinputs : hashInputs (liftM (OracleWorld.query input)) ⊆ inputs)
+    (hmessage : ∀ hash, input = .inr hash → MessageHashInput parameter hash)
+    (state : State inputs) (hcovered : ResidualByteFrontend.RowsCovered inputs (project state)) :
+    cacheResult <$> lazyByteRun parameter inputs hencoding words publicReplies selections rows routing
+      (liftM (OracleWorld.query input)) state =
+      Prod.map some id <$> 𝒟[(romImpl input).run state.memory.external.cache] := by
+  have hm : ResidualByteFrontend.MessageOnly parameter (liftM (OracleWorld.query input)) := by
+    rw [← bind_pure (liftM (OracleWorld.query input))]
+    apply ResidualByteFrontend.messageOnly_query_bind
+    · cases input with
+      | inl _ => trivial
+      | inr hash => exact hmessage hash rfl
+    · intro answer
+      exact ResidualByteFrontend.messageOnly_pure parameter answer
+  simpa only [simulateQ_spec_query] using
+    lazyByteRun_message_rom parameter inputs hencoding words publicReplies selections rows routing
+      (liftM (OracleWorld.query input)) hinputs hm state hcovered
+
+theorem lazyRun_routing_bind {Result : Type} (next : Routing → OracleComp (World inputs) Result) (state : State inputs) :
+    lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+      (currentRouting inputs >>= next) state =
+      lazyRun (environment parameter inputs hencoding words publicReplies selections rows) (next state.memory.routing) state := by
+  rw [currentRouting, lazyRun, runWith_query_bind]
+  simp only [lazyImpl, environment, OptionT.run_mk, StateT.run_mk, SPMF.lift_pure, pure_bind, Option.elim_some, lazyRun]
+
+theorem lazyRun_externalProgram {Result : Type} (computation : OracleComp OracleWorld Result) (state : State inputs) :
+    lazyRun (environment parameter inputs hencoding words publicReplies selections rows)
+      (externalProgram inputs parameter words selections computation) state =
+      lazyByteRun parameter inputs hencoding words publicReplies selections rows state.memory.routing computation state := by
+  rw [externalProgram, lazyRun_routing_bind]
+  rfl
+
+end SphincsSecurity.Concrete.RetainedResidual
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedSigningTrace.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedSigningTrace.lean
new file mode 100644
index 000000000..c0ee5662f
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedSigningTrace.lean
@@ -0,0 +1,69 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Fts.FtsProbeSampling
+namespace SphincsSecurity.Concrete.FtsProbeSimulation
+
+open _root_.OracleComp OracleSpec
+set_option backward.isDefEq.respectTransparency false
+
+theorem signingTraceComputation_bind
+    (computation : OracleComp (OracleWorld + SigningSpec) α)
+    (next : α → OracleComp (OracleWorld + SigningSpec) β) :
+    signingTraceComputation (computation >>= next) = (do
+      let left ← signingTraceComputation computation
+      let right ← signingTraceComputation (next left.1)
+      pure (right.1, left.2 ++ right.2)) := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => simp [signingTraceComputation]
+  | query_bind input tail ih =>
+      simp only [bind_assoc, signingTraceComputation_query_bind, map_eq_bind_pure_comp]
+      apply bind_congr
+      intro reply
+      rw [ih reply]
+      simp only [bind_assoc, pure_bind]
+      apply bind_congr
+      intro left
+      apply bind_congr
+      intro right
+      simp only [List.append_assoc, Function.comp_apply]
+
+theorem signingTraceComputation_liftOracleWorldLeft
+    (computation : OracleComp OracleWorld α) :
+    signingTraceComputation (liftOracleWorldLeft computation) =
+      (fun value => (value, [])) <$> liftOracleWorldLeft computation := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => rfl
+  | query_bind input next ih =>
+      have hlift : liftOracleWorldLeft (OracleSpec.query input >>= next) =
+          ((liftM (OracleSpec.query (spec := OracleWorld + SigningSpec) (.inl input)) :
+            OracleComp (OracleWorld + SigningSpec) _) >>= fun reply => liftOracleWorldLeft (next reply)) := by
+        letI directLift : MonadLift (OracleQuery OracleWorld) (OracleQuery (OracleWorld + SigningSpec)) :=
+          (OracleQuery.subSpec_add_left (spec₁ := OracleWorld) (spec₂ := SigningSpec)).toMonadLift
+        unfold liftOracleWorldLeft
+        rw [liftM_bind]
+        rfl
+      rw [hlift, signingTraceComputation_query_bind, map_bind]
+      apply bind_congr
+      intro reply
+      rw [ih reply]
+      simp only [Functor.map_map, signingLogFragment, List.nil_append]
+
+noncomputable def unloggedRetainedRestComputation (adversary : Adversary) (publicKey : PublicKey) :
+    OracleComp (OracleWorld + SigningSpec) (Forgery × Bool) := do
+  let forgery ← adversary.main publicKey
+  let verified ← liftOracleWorldLeft (scheme.verify publicKey forgery.message forgery.signature)
+  pure (forgery, verified)
+
+def arrangeRetainedTrace (result : (Forgery × Bool) × QueryLog SigningSpec) : RetainedRestResult :=
+  ((result.1.1, result.2), result.1.2)
+
+theorem retainedGameRestComputation_eq_signingTrace
+    (adversary : Adversary) (publicKey : PublicKey) :
+    retainedGameRestComputation adversary publicKey =
+      arrangeRetainedTrace <$> signingTraceComputation (unloggedRetainedRestComputation adversary publicKey) := by
+  simp only [retainedGameRestComputation, unloggedRetainedRestComputation, signingTraceComputation_bind, map_bind]
+  apply bind_congr
+  intro result
+  simp only [signingTraceComputation_liftOracleWorldLeft]
+  simp [signingTraceComputation, arrangeRetainedTrace]
+
+end SphincsSecurity.Concrete.FtsProbeSimulation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedWorldCoverBudget.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedWorldCoverBudget.lean
new file mode 100644
index 000000000..04d83242d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/RetainedWorldCoverBudget.lean
@@ -0,0 +1,33 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Ots.OtsProbeOrigin
+import SphincsSecurity.Proof.Residual.RetainedSigningTrace
+namespace SphincsSecurity.Concrete.FtsProbeSimulation
+
+open _root_.OracleComp OracleSpec ENNReal
+attribute [local instance] Classical.propDecidable
+set_option backward.isDefEq.respectTransparency false
+
+theorem signingTraceComputation_fst {α : Type} (computation : OracleComp (OracleWorld + SigningSpec) α) :
+    Prod.fst <$> signingTraceComputation computation = computation := by
+  induction computation using OracleComp.inductionOn with
+  | pure value => simp [signingTraceComputation]
+  | query_bind input next ih =>
+      rw [signingTraceComputation_query_bind, map_bind]
+      apply bind_congr
+      intro reply
+      rw [Functor.map_map]
+      exact ih reply
+
+theorem expanded_unloggedRetainedRest_queryBound (adversary : Adversary) (key : SecretKey) (q : Nat)
+    (hbound : (gameRest scheme adversary ⟨key.root, key.parameter⟩ key).IsQueryBoundP (· matches Sum.inr _) q) :
+    (simulateQ (expandedAdversaryImpl key)
+      (unloggedRetainedRestComputation adversary ⟨key.root, key.parameter⟩)).IsQueryBoundP (· matches Sum.inr _) q := by
+  have h := simulateQ_expanded_retainedGameRestComputation_isQueryBoundP adversary key q hbound
+  rw [retainedGameRestComputation_eq_signingTrace, simulateQ_map, isQueryBoundP_map_iff] at h
+  have heq : Prod.fst <$> simulateQ (expandedAdversaryImpl key)
+      (signingTraceComputation (unloggedRetainedRestComputation adversary ⟨key.root, key.parameter⟩)) =
+        simulateQ (expandedAdversaryImpl key) (unloggedRetainedRestComputation adversary ⟨key.root, key.parameter⟩) := by
+    rw [← simulateQ_map, signingTraceComputation_fst]
+  exact (isQueryBoundP_iff_of_map_eq (p := (· matches Sum.inr _)) heq).mp h
+
+end SphincsSecurity.Concrete.FtsProbeSimulation
diff --git a/formal/sphincs/SphincsSecurity/Proof/Residual/Security127LargeBudget.lean b/formal/sphincs/SphincsSecurity/Proof/Residual/Security127LargeBudget.lean
new file mode 100644
index 000000000..4c9f1aac7
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Residual/Security127LargeBudget.lean
@@ -0,0 +1,55 @@
+import SphincsSecurity.Proof.Residual.RetainedResidualCacheTail
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+
+private theorem largeRangeClosing (x : ℝ) (hx : 3 / 16384 ≤ x) :
+    2 * x - x ^ 2 + (11 / 65536) * x + (x / 2 ^ 41 + 1 / 2 ^ 700) ≤ 2 * x := by
+  have hn : 0 ≤ x := le_trans (by norm_num) hx
+  have hs := mul_nonneg (sub_nonneg.mpr hx) hn
+  have he : (1 : ℝ) / 2 ^ 700 ≤ 1 / 1099511627776 := by
+    calc
+      _ ≤ 1 / (2 : ℝ) ^ 40 := one_div_le_one_div_of_le (by positivity)
+        (pow_le_pow_right₀ (by norm_num) (by decide : 40 ≤ 700))
+      _ = _ := by norm_num
+  apply le_trans (add_le_add le_rfl (add_le_add le_rfl he))
+  norm_num at hx hs ⊢
+  nlinarith
+
+theorem native_bound_le_security127 (q : Nat) (hlarge : 3 * 2 ^ 114 ≤ q) (hsmall : q ≤ 2 ^ 127) :
+    ENNReal.ofReal (2 * ((q : ℝ) / 2 ^ digestBits) - ((q : ℝ) / 2 ^ digestBits) ^ 2) +
+      (q : ENNReal) * (11 / 2 ^ 144 : ENNReal) +
+      ((q : ENNReal) * (2 ^ 169 : ENNReal)⁻¹ + (2 ^ 700 : ENNReal)⁻¹) ≤ (q : ENNReal) / 2 ^ 127 := by
+  let x : ℝ := (q : ℝ) / 2 ^ 128
+  have hx : 3 / 16384 ≤ x := by
+    have hq : (3 * 2 ^ 114 : ℝ) ≤ q := by exact_mod_cast hlarge
+    apply (le_div_iff₀ (by positivity)).mpr
+    norm_num at hq ⊢
+    exact hq
+  have hn : 0 ≤ x := by positivity
+  have hu : x ≤ 1 / 2 := by
+    have hq : (q : ℝ) ≤ 2 ^ 127 := by exact_mod_cast hsmall
+    apply (div_le_iff₀ (by positivity)).mpr
+    norm_num at hq ⊢
+    exact hq
+  have hp : 0 ≤ 2 * ((q : ℝ) / 2 ^ digestBits) - ((q : ℝ) / 2 ^ digestBits) ^ 2 := by
+    change 0 ≤ 2 * x - x ^ 2
+    nlinarith
+  apply (ENNReal.toReal_le_toReal (by finiteness) (by finiteness)).mp
+  repeat rw [ENNReal.toReal_add (by finiteness) (by finiteness)]
+  rw [ENNReal.toReal_ofReal hp]
+  simp only [ENNReal.toReal_mul, ENNReal.toReal_div, ENNReal.toReal_inv, ENNReal.toReal_pow, ENNReal.toReal_natCast, ENNReal.toReal_ofNat]
+  convert largeRangeClosing x hx using 1 <;> generalize (2 : ℝ) ^ 700 = tailDenominator <;> dsimp only [x, digestBits] <;> ring
+
+theorem security127_of_large_budget (q : Nat) (hlarge : 3 * 2 ^ 114 ≤ q) (adversary : Adversary)
+    (hcost : HasHashQueryBound scheme adversary q) : forgeAdvantage scheme adversary ≤ (q : ENNReal) / 2 ^ 127 := by
+  by_cases hsmall : q ≤ 2 ^ 127
+  · exact (RetainedResidual.forgeAdvantage_le_native_bound fixedReferenceDummy
+      (fun _ _ _ => fixedReferenceDummyWord_valid) adversary q hcost hsmall).trans
+        (native_bound_le_security127 q hlarge hsmall)
+  · apply probOutput_le_one.trans
+    calc
+      (1 : ENNReal) = (2 ^ 127 : ENNReal) / 2 ^ 127 := (ENNReal.div_self (by positivity) (by finiteness)).symm
+      _ ≤ _ := ENNReal.div_le_div_right (by exact_mod_cast (show 2 ^ 127 ≤ q by omega)) _
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Scheme/Arith.lean b/formal/sphincs/SphincsSecurity/Proof/Scheme/Arith.lean
new file mode 100644
index 000000000..ac00cc8f9
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Scheme/Arith.lean
@@ -0,0 +1,50 @@
+import SphincsSecurity.Proof.Base.Prelude
+/-!
+# 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/Scheme/Bytes.lean b/formal/sphincs/SphincsSecurity/Proof/Scheme/Bytes.lean
new file mode 100644
index 000000000..78aaef8a7
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Scheme/Bytes.lean
@@ -0,0 +1,154 @@
+import SphincsSecurity.Proof.Base.Prelude
+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/Scheme/Cached.lean b/formal/sphincs/SphincsSecurity/Proof/Scheme/Cached.lean
new file mode 100644
index 000000000..2b740277c
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Scheme/Cached.lean
@@ -0,0 +1,56 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Scheme.Queried
+import SphincsSecurity.Proof.Hypertree.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_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
+
+namespace Concrete
+
+variable {f : QueryImpl HashSpec Id} {parameter : PublicParameter}
+  {otsSecret : Layer → TreeIndex → LeafIndex → ChainIndex → Digest}
+  {ftsSecret : Index → FtsTree → FtsLeaf → Digest}
+  {cache : QueryCache HashSpec}
+
+end Concrete
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Scheme/Charge.lean b/formal/sphincs/SphincsSecurity/Proof/Scheme/Charge.lean
new file mode 100644
index 000000000..7f67351ac
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Scheme/Charge.lean
@@ -0,0 +1,116 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.Settled
+import SphincsSecurity.Proof.Scheme.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
+
+/-- **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
+
+/-! ### One fresh query -/
+
+/-! ### The potential -/
+
+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]
+
+/-- 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_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 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
+
+/-! ### How one query moves the pieces -/
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Scheme/Code.lean b/formal/sphincs/SphincsSecurity/Proof/Scheme/Code.lean
new file mode 100644
index 000000000..796af7fc3
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Scheme/Code.lean
@@ -0,0 +1,154 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Scheme.Bytes
+/-!
+# 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)
+
+noncomputable instance instDecidablePredDigestValidDigest : DecidablePred ValidDigest :=
+  Classical.decPred _
+
+/-- 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
+
+/-- 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/Scheme/Eval.lean b/formal/sphincs/SphincsSecurity/Proof/Scheme/Eval.lean
new file mode 100644
index 000000000..28922331e
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Scheme/Eval.lean
@@ -0,0 +1,35 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Statement
+
+/-!
+# 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/Scheme/Execution.lean b/formal/sphincs/SphincsSecurity/Proof/Scheme/Execution.lean
new file mode 100644
index 000000000..e038aa3c5
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Scheme/Execution.lean
@@ -0,0 +1,37 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Statement
+
+/-!
+# 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)
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Scheme/FirstBad.lean b/formal/sphincs/SphincsSecurity/Proof/Scheme/FirstBad.lean
new file mode 100644
index 000000000..46cfa115f
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Scheme/FirstBad.lean
@@ -0,0 +1,63 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Scheme.Charge
+/-!
+# 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
+
+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
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Scheme/ForgeryClassify.lean b/formal/sphincs/SphincsSecurity/Proof/Scheme/ForgeryClassify.lean
new file mode 100644
index 000000000..c35b9c877
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Scheme/ForgeryClassify.lean
@@ -0,0 +1,120 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Ots.LayerCompare
+/-!
+# 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 VerifierLayerMessage (f : QueryImpl HashSpec Id) (parameter : PublicParameter)
+    (index : Index) (leaves : IndexGroup → 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 FullyHonestOpening (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec)
+    (secretKey : SecretKey) (index : Index) (leaves : IndexGroup → 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))
+
+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
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Scheme/Guess.lean b/formal/sphincs/SphincsSecurity/Proof/Scheme/Guess.lean
new file mode 100644
index 000000000..ca55d5e08
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Scheme/Guess.lean
@@ -0,0 +1,36 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Statement
+
+/-!
+# 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
+
+/-! ### 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
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Scheme/NoMessage.lean b/formal/sphincs/SphincsSecurity/Proof/Scheme/NoMessage.lean
new file mode 100644
index 000000000..11fccaf55
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Scheme/NoMessage.lean
@@ -0,0 +1,264 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.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 : IndexGroup → 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 : IndexGroup → 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 sequenceFin (m := Option) 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 : IndexGroup → 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/Scheme/Queried.lean b/formal/sphincs/SphincsSecurity/Proof/Scheme/Queried.lean
new file mode 100644
index 000000000..697808834
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Scheme/Queried.lean
@@ -0,0 +1,188 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Scheme.Eval
+import SphincsSecurity.Proof.Ots.ExtractChain
+import SphincsSecurity.Proof.Fts.ExtractFts
+import SphincsSecurity.Proof.Scheme.Support
+/-!
+# 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 : IndexGroup → 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 : IndexGroup → 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 : IndexGroup → 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/Scheme/RawQueryMomentBound.lean b/formal/sphincs/SphincsSecurity/Proof/Scheme/RawQueryMomentBound.lean
new file mode 100644
index 000000000..960bfd264
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Scheme/RawQueryMomentBound.lean
@@ -0,0 +1,178 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Base.BinomialMoments
+import SphincsSecurity.Proof.Fts.ReuseRawEnvelope
+import SphincsSecurity.Proof.Fts.TargetIndexEnvelope
+import SphincsSecurity.Proof.Fts.TargetShapeExpectation
+namespace SphincsSecurity.Concrete
+
+open ENNReal
+
+noncomputable def indexPowerVector (cache signings : ENNReal) : TargetIndexVector :=
+  fun power degree => cache ^ power * signings ^ degree
+
+def TargetIndexDegreeLE (bound : Nat) (first second : TargetIndexVector) : Prop :=
+  ∀ power degree, power + degree ≤ bound → first power degree ≤ second power degree
+
+theorem targetIndexCacheLower_degree_mono {bound : Nat} {first second : TargetIndexVector}
+    (h : TargetIndexDegreeLE bound first second) :
+    TargetIndexDegreeLE bound (targetIndexCacheLower first) (targetIndexCacheLower second) := by
+  intro power degree hdegree
+  apply Finset.sum_le_sum
+  intro lower hlower
+  apply mul_le_mul' le_rfl
+  exact h lower degree (by have := Finset.mem_range.mp hlower; omega)
+
+theorem targetIndexTreeLower_degree_mono {bound : Nat} {first second : TargetIndexVector}
+    (h : TargetIndexDegreeLE bound first second) :
+    TargetIndexDegreeLE bound (targetIndexTreeLower first) (targetIndexTreeLower second) := by
+  intro power degree hdegree
+  apply Finset.sum_le_sum
+  intro lower hlower
+  apply mul_le_mul' le_rfl
+  exact h power lower (by have := Finset.mem_range.mp hlower; omega)
+
+theorem targetIndexReuseStep_degree_mono {bound : Nat} {first second : TargetIndexVector}
+    (h : TargetIndexDegreeLE bound first second) :
+    TargetIndexDegreeLE bound (targetIndexReuseStep first) (targetIndexReuseStep second) := by
+  intro power degree hdegree
+  unfold targetIndexReuseStep targetIndexTreeLower
+  apply Finset.sum_le_sum
+  intro lower hlower
+  apply mul_le_mul' le_rfl
+  exact h (power + 1) lower (by have := Finset.mem_range.mp hlower; omega)
+
+theorem targetIndexSigning_degree_mono (uniform reuse : ENNReal)
+    {bound : Nat} {first second : TargetIndexVector} (h : TargetIndexDegreeLE bound first second) :
+    TargetIndexDegreeLE bound (targetIndexSigning uniform reuse first) (targetIndexSigning uniform reuse second) := by
+  intro power degree hdegree
+  exact add_le_add
+    (add_le_add (h power degree hdegree) (mul_le_mul' le_rfl
+      (add_le_add (add_le_add (targetIndexCacheLower_degree_mono h power degree hdegree)
+        (targetIndexTreeLower_degree_mono h power degree hdegree))
+        (targetIndexCacheLower_degree_mono (targetIndexTreeLower_degree_mono h) power degree hdegree))))
+    (mul_le_mul' le_rfl (targetIndexReuseStep_degree_mono h power degree hdegree))
+
+theorem targetIndexSigning_iterate_degree_mono (uniform reuse : ENNReal) (signings : Nat)
+    {bound : Nat} {first second : TargetIndexVector} (h : TargetIndexDegreeLE bound first second) :
+    TargetIndexDegreeLE bound ((targetIndexSigning uniform reuse)^[signings] first)
+      ((targetIndexSigning uniform reuse)^[signings] second) := by
+  induction signings with
+  | zero => exact h
+  | succ signings ih =>
+      simp only [Function.iterate_succ_apply']
+      exact targetIndexSigning_degree_mono uniform reuse ih
+
+theorem ennreal_add_one_pow (value : ENNReal) (degree : Nat) :
+    (value + 1) ^ degree = value ^ degree +
+      ∑ lower ∈ Finset.range degree, (degree.choose lower : ENNReal) * value ^ lower := by
+  rw [add_pow, Finset.sum_range_succ]
+  simp only [one_pow, mul_one, Nat.choose_self, Nat.cast_one]
+  rw [add_comm]
+  apply congrArg (value ^ degree + ·)
+  apply Finset.sum_congr rfl
+  intro lower _
+  exact mul_comm _ _
+
+theorem indexPowerVector_cache_succ (cache signings : ENNReal) (power degree : Nat) :
+    indexPowerVector (cache + 1) signings power degree =
+      indexPowerVector cache signings power degree + targetIndexCacheLower (indexPowerVector cache signings) power degree := by
+  simp only [indexPowerVector, ennreal_add_one_pow, add_mul, Finset.sum_mul, targetIndexCacheLower]
+  congr 1
+  apply Finset.sum_congr rfl
+  intro lower _
+  ring
+
+theorem targetIndexQuery_power {rate : ENNReal} (hrate : rate ≤ 1)
+    (cache signings : ENNReal) (power degree : Nat) :
+    targetIndexQuery rate (indexPowerVector cache signings) power degree =
+      (1 - rate) * indexPowerVector cache signings power degree +
+        rate * indexPowerVector (cache + 1) signings power degree := by
+  rw [indexPowerVector_cache_succ, bernoulli_mix_increment hrate]
+  rfl
+
+theorem targetIndexQuery_binomialAverage (arrival rate : ENNReal) (steps : Nat)
+    (moments : Nat → TargetIndexVector) (power degree : Nat) :
+    targetIndexQuery arrival (fun p d => binomialAverage rate steps (fun count => moments count p d)) power degree =
+      binomialAverage rate steps (fun count => targetIndexQuery arrival (moments count) power degree) := by
+  simp only [targetIndexQuery, targetIndexCacheLower, binomialAverage_add,
+    binomialAverage_mul_left, binomialAverage_sum]
+
+theorem targetIndexQuery_iterate_power {rate : ENNReal} (hrate : rate ≤ 1)
+    (cache signings : ENNReal) (queries power degree : Nat) :
+    (targetIndexQuery rate)^[queries] (indexPowerVector cache signings) power degree =
+      binomialAverage rate queries (fun count => indexPowerVector (cache + count) signings power degree) := by
+  induction queries generalizing power degree with
+  | zero => simp [binomialAverage_zero]
+  | succ queries ih =>
+      have hfun : (targetIndexQuery rate)^[queries] (indexPowerVector cache signings) =
+          fun p d => binomialAverage rate queries (fun count => indexPowerVector (cache + count) signings p d) := by
+        funext p d
+        exact ih p d
+      rw [Function.iterate_succ_apply', hfun, targetIndexQuery_binomialAverage]
+      simp_rw [targetIndexQuery_power hrate]
+      rw [binomialAverage_add, binomialAverage_mul_left, binomialAverage_mul_left, binomialAverage_succ]
+      simp only [Nat.cast_add, Nat.cast_one, add_assoc]
+
+theorem targetIndexQuery_iterate_power_le {rate : ENNReal} (hrate : rate ≤ 1)
+    (cache signings : ENNReal) (queries bound : Nat) :
+    TargetIndexDegreeLE bound ((targetIndexQuery rate)^[queries] (indexPowerVector cache signings))
+      (indexPowerVector (cache + queries * rate + bound) signings) := by
+  intro power degree hdegree
+  rw [targetIndexQuery_iterate_power hrate]
+  simp only [indexPowerVector, binomialAverage_mul_right]
+  apply mul_le_mul' _ le_rfl
+  exact (binomialAverage_shifted_power_le hrate cache queries power).trans
+    (pow_le_pow_left' (add_le_add le_rfl (Nat.cast_le.mpr (by omega : power ≤ bound))) power)
+
+theorem targetIndexEnvelope_power_query_shift_le {rate : ENNReal} (hrate : rate ≤ 1)
+    (uniform reuse cache signings : ENNReal) (queries signatures bound power degree : Nat)
+    (hdegree : power + degree ≤ bound) :
+    targetIndexEnvelope uniform reuse rate queries signatures (indexPowerVector cache signings) power degree ≤
+      (targetIndexSigning uniform reuse)^[signatures]
+        (indexPowerVector (cache + queries * rate + bound) signings) power degree :=
+  targetIndexSigning_iterate_degree_mono uniform reuse signatures
+    (targetIndexQuery_iterate_power_le hrate cache signings queries bound) power degree hdegree
+
+theorem targetShapeEnvelope_sum_indexPower {α : Type} [Fintype α]
+    (uniform reuse arrival : ENNReal) (queries signatures : Nat) (cache signings : α → ENNReal)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree) (hvalid : TargetShapeValid groups remaining) :
+    targetShapeEnvelope uniform reuse arrival queries signatures
+      (fun G R => ∑ i, indexPowerVector (cache i) (signings i) G.card R.card) groups remaining =
+      ∑ i, targetIndexEnvelope uniform reuse arrival queries signatures
+        (indexPowerVector (cache i) (signings i)) groups.card remaining.card := by
+  have hsum : (fun G R => ∑ i, indexPowerVector (cache i) (signings i) G.card R.card) =
+      fun G R => ∑' i, liftTargetIndexVector (indexPowerVector (cache i) (signings i)) G R := by
+    funext G R
+    rw [tsum_fintype]
+    rfl
+  rw [hsum, targetShapeEnvelope_tsum, tsum_fintype]
+  apply Finset.sum_congr rfl
+  intro i _
+  exact targetShapeEnvelope_lift uniform reuse arrival queries signatures _ groups remaining hvalid
+
+theorem reuseRawEnvelope_query_shift_le (key : SecretKey) (reuse : ENNReal)
+    (queries signatures bound : Nat) (state : CoverLogState)
+    (groups : Finset (Finset FtsTree)) (remaining : Finset FtsTree)
+    (hvalid : TargetShapeValid groups remaining) (hdegree : groups.card + remaining.card ≤ bound) :
+    reuseRawEnvelope key reuse queries signatures state groups remaining ≤
+      ∑ index : Index, (targetIndexSigning (Fintype.card Index : ENNReal)⁻¹ reuse)^[signatures]
+        (indexPowerVector
+          (cachedIndexMultiplicity key.parameter state.1 index +
+            (queries : ENNReal) * ((2 ^ 36 : Nat) : ENNReal)⁻¹ + bound)
+          ((signingSlotsAtIndex (observedOptionalSigningViews
+            (FtsProbeSimulation.messageAnswers key.parameter state.1) key.root state.2) index).card : ENNReal))
+        groups.card remaining.card := by
+  have harrival : (((2 ^ ftsTreeHeight : Nat) : ENNReal)⁻¹ * (Fintype.card Index : ENNReal)⁻¹) =
+      ((2 ^ 36 : Nat) : ENNReal)⁻¹ := by
+    rw [← ENNReal.mul_inv (Or.inr (by finiteness)) (Or.inl (by finiteness))]
+    norm_num [ftsTreeHeight, Index, totalHeight]
+  have hrate : (((2 ^ 36 : Nat) : ENNReal)⁻¹) ≤ 1 := by norm_num
+  unfold reuseRawEnvelope observedRawIndexShapeVector liftTargetIndexVector targetIndexMoments
+  change targetShapeEnvelope _ _ _ queries signatures
+    (fun G R => ∑ index : Index, indexPowerVector _ _ G.card R.card) groups remaining ≤ _
+  rw [targetShapeEnvelope_sum_indexPower _ _ _ _ _ _ _ groups remaining hvalid, harrival]
+  apply Finset.sum_le_sum
+  intro index _
+  exact targetIndexEnvelope_power_query_shift_le hrate _ _ _ _ queries signatures bound _ _ hdegree
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Scheme/Replay.lean b/formal/sphincs/SphincsSecurity/Proof/Scheme/Replay.lean
new file mode 100644
index 000000000..caefb259d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Scheme/Replay.lean
@@ -0,0 +1,25 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Ots.EncodingCached
+import SphincsSecurity.Proof.Scheme.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
+
+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'⟩
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Scheme/ReplayWorld.lean b/formal/sphincs/SphincsSecurity/Proof/Scheme/ReplayWorld.lean
new file mode 100644
index 000000000..80f81802b
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Scheme/ReplayWorld.lean
@@ -0,0 +1,120 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Scheme.Cached
+import SphincsSecurity.Proof.Scheme.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 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/Scheme/Secrets.lean b/formal/sphincs/SphincsSecurity/Proof/Scheme/Secrets.lean
new file mode 100644
index 000000000..ceac2744a
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Scheme/Secrets.lean
@@ -0,0 +1,85 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Reference.QueryBound
+/-!
+# Splitting the game at the secrets
+
+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: `gameRest` is everything the game does after key generation. 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 useful split is inside key generation: `gameAfterSecrets` 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
+
+/-- 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
+
+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 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/Scheme/SignSupport.lean b/formal/sphincs/SphincsSecurity/Proof/Scheme/SignSupport.lean
new file mode 100644
index 000000000..56a6af967
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Scheme/SignSupport.lean
@@ -0,0 +1,158 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.Descent
+import SphincsSecurity.Proof.Scheme.ReplayWorld
+/-!
+# 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)
+
+def SuccessfulDigestRun (f : QueryImpl HashSpec Id) (cache : QueryCache HashSpec)
+    (secretKey : SecretKey) (message : Message) (randomness : Randomness) (index : Index)
+    (leaves : IndexGroup → 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 : IndexGroup → 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 : IndexGroup → 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⟩
+
+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
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Scheme/Slot.lean b/formal/sphincs/SphincsSecurity/Proof/Scheme/Slot.lean
new file mode 100644
index 000000000..57859df24
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Scheme/Slot.lean
@@ -0,0 +1,27 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.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
+
+/-- 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]
+
+end SphincsSecurity
diff --git a/formal/sphincs/SphincsSecurity/Proof/Scheme/StatementLemmas.lean b/formal/sphincs/SphincsSecurity/Proof/Scheme/StatementLemmas.lean
new file mode 100644
index 000000000..aabe5fd1d
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Scheme/StatementLemmas.lean
@@ -0,0 +1,237 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Statement
+
+/-!
+# Facts about the statement
+
+`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. It also checks the arithmetic the concrete parameters fix: the layer heights, the index decomposition and the authentication path offsets.
+-/
+
+namespace SphincsSecurity.Concrete
+
+theorem _root_.SphincsSecurity.layerHeight_le (lay : Layer) : layerHeight lay ≤ maxLayerHeight := by
+  unfold layerHeight maxLayerHeight
+  split <;> omega
+
+attribute [local semireducible] treeNode ftsNode verify sign sampleRandomness
+
+noncomputable local instance instSampleableTypeRandomness_1 : 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 sequenceFin (m := Option) 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
+
+/-! ## Parameter arithmetic -/
+
+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
+
+/-- The digest is `h + k * a = 176` bits and has to fit in one oracle output. -/
+example : messageDigestBits = 176 ∧ messageDigestBits ≤ hashOutputBits := by decide
+
+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]
+
+/-- 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]
+
+/-- 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
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Proof/Scheme/Support.lean b/formal/sphincs/SphincsSecurity/Proof/Scheme/Support.lean
new file mode 100644
index 000000000..f3ab491f1
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Scheme/Support.lean
@@ -0,0 +1,289 @@
+import SphincsSecurity.Proof.Base.Prelude
+import SphincsSecurity.Proof.Hypertree.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
+
+/-! ### 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/Security127Completion.lean b/formal/sphincs/SphincsSecurity/Proof/Security127Completion.lean
new file mode 100644
index 000000000..0a71294da
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Proof/Security127Completion.lean
@@ -0,0 +1,32 @@
+import SphincsSecurity.Proof.Forced.FtsGuessNearAssembly
+import SphincsSecurity.Proof.Residual.Security127LargeBudget
+/-!
+The small-budget half of the `127`-bit claim. Below `3 * 2^114` hash queries the original SUF advantage is at most the retained residual terms plus the normalized sum, over the test positions, of the forced FTS near-certificate probabilities, each of which `nearCertificateBound` bounds. The closing arithmetic is `small_bound_le_security127`, and `security127_of_large_budget` covers the remaining budgets.
+-/
+
+namespace SphincsSecurity.Concrete
+
+open _root_.OracleComp OracleSpec ENNReal
+
+theorem security127_of_small_budget (q : Nat) (hq : 1 ≤ q) (hsmall : q ≤ 3 * 2 ^ 114) (adversary : Adversary)
+    (hbound : HasHashQueryBound scheme adversary q) : forgeAdvantage scheme adversary ≤ (q : ENNReal) / 2 ^ 127 := by
+  have hbudget : q ≤ 2 ^ 127 := by omega
+  have hslots : (∑ slot ∈ Finset.range q, Pr[fun hit => hit = true | FtsGuessHash.forcedNearGame fixedReferenceDummy adversary slot]) ≤
+      (q : ENNReal) * nearCertificateBound q := by
+    refine (Finset.sum_le_card_nsmul _ _ _ fun slot _ =>
+      FtsGuessHash.forcedNearGame_le fixedReferenceDummy adversary q hbound hbudget slot).trans ?_
+    rw [Finset.card_range, nsmul_eq_mul]
+  refine (forgeAdvantage_le_forcedNear_small_budget fixedReferenceDummy (fun _ _ _ => fixedReferenceDummyWord_valid) adversary q hbound
+    hsmall).trans ?_
+  refine (add_le_add le_rfl (mul_le_mul' le_rfl hslots)).trans ?_
+  exact small_bound_le_security127 q hq hsmall
+
+/-- `127` bits of classical strong unforgeability for the concrete SPHINCS instance: every adversary whose whole experiment makes at most `q ≥ 1` hash queries forges with probability at most `q / 2^127`. -/
+theorem security127 : HasClassicalSecurityBits scheme 127 := by
+  intro q hq adversary hbound
+  rw [Nat.cast_pow, Nat.cast_ofNat]
+  by_cases hsmall : q ≤ 3 * 2 ^ 114
+  · exact security127_of_small_budget q hq hsmall adversary hbound
+  · exact security127_of_large_budget q (by omega) adversary hbound
+
+end SphincsSecurity.Concrete
diff --git a/formal/sphincs/SphincsSecurity/Statement.lean b/formal/sphincs/SphincsSecurity/Statement.lean
new file mode 100644
index 000000000..0ea2d986e
--- /dev/null
+++ b/formal/sphincs/SphincsSecurity/Statement.lean
@@ -0,0 +1,754 @@
+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
+
+The reviewer-facing statement of what is proven: 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 claim `SphincsSecurityStatement`. Nothing here is a reduction or an intermediate game, and nothing instantiates the hash: it is a random oracle throughout. The arithmetic the parameters fix about the layout, the index decomposition and the authentication path offsets, is checked in `Proof/Scheme/StatementLemmas.lean`.
+
+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. The scheme is stateless, so a signing request is a message alone and the game caps the number of signing queries; signing is randomized, a fresh randomizer per digest attempt, so a second signature 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, as `Sig` is specified.
+
+The claim is `127` bits: every adversary whose whole experiment, key generation, signing and verification included, makes at most `q ≥ 1` hash queries forges with probability at most `q / 2^127`. The model is the classical random-oracle model with independently sampled secrets; the seed derivation of the secrets and the instantiation with BLAKE2s are outside it.
+-/
+
+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
+
+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
+/-- `idx`, which few-time key signs. -/
+abbrev Index := Fin (2 ^ totalHeight)
+/-- `tau`, a tree of any layer. Layer `lay` only uses the values below `2^(sum_{j < lay} h_j)`. -/
+abbrev TreeIndex := Fin (2 ^ totalHeight)
+/-- `e`, a leaf of any layer. Layer `lay` only uses the values below `2^h_lay`. -/
+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`. The first `k - 1` select a tree's leaf; the last is pinned to zero. -/
+abbrev IndexGroup := 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
+
+/-- 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
+
+/-- Keep the first `h + k * a` output bits. -/
+def truncateMessageDigest (output : HashOutput) : MessageDigest :=
+  output.extractLsb' 0 messageDigestBits
+
+/-- `pk = (root, P)`. -/
+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, at every position of the index types, so positions a layer does not have hold secrets nothing reads; 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)
+
+/-- The five fields of the specification's `enc(t, lay, tau, p, j)`. -/
+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
+
+/-- The digit sum of a word. -/
+def sum (x : Encoding) : Nat := ∑ i, (x i).val
+
+/-- Membership in the code `C`: digit sum `T`. -/
+def Valid (x : Encoding) : Prop := sum x = targetSum
+
+instance : DecidablePred Valid :=
+  fun x => inferInstanceAs (Decidable (sum x = targetSum))
+
+/-- `v / 2 = 21` digits in each half of the digest. -/
+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
+
+/-- `x_i`, the three bits of the digest at the digit's offset. -/
+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 as run in the experiment, with every oracle hash call they make. Key generation samples the parameter and every secret and builds layer `0`'s tree; signing rebuilds whatever tree it reads rather than caching anything; verification is the ordinary verifier. Everything under `Concrete` is the instance; the experiment after it is generic over `Scheme`. The hashing algorithms are written for any monad `m` that can query the hash, and key generation and signing run them with `liftM` inside the world that also samples. Branches that return `0` out of range exist only to make the definitions total; the honest algorithms never take them and verification never reads them. The `irreducible` attributes at the end of the namespace only seal definitions against accidental unfolding in proofs, and Lean restricts global reducibility attributes to the defining module. -/
+
+/-- 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
+
+/-- Run the `n` computations in index order and collect their results. -/
+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
+
+variable {m : Type → Type} [Monad m] [HasQuery HashSpec m]
+
+/-- One query to the random oracle `H`. -/
+def oracleHash (input : HashInput) : m HashOutput :=
+  HasQuery.query (spec := HashSpec) (m := m) input
+
+/-- `Th(P, tw, M) = Truncate_n(H(tw || P || M))`. -/
+def tweakableHash (parameter : PublicParameter) (domain : HashDomain) (payload : HashInput) :
+    m Digest := do
+  let output ← oracleHash (tweakableHashInput parameter domain payload)
+  return truncateHash output
+
+/-! ### 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,
+    Nat.lt_of_lt_of_le (Nat.mod_lt _ (Nat.two_pow_pos _)) (Nat.pow_le_pow_right (by omega) (by
+      unfold layerHeight maxLayerHeight; split <;> omega))⟩
+
+/-! ### The one-time signature -/
+
+/-- A node index at level `0` read as a leaf index. -/
+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 (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 (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
+
+/-- `pk_i = Chain(P, 0, 2^w - 1, sk_i)` for every chain. -/
+def oneTimePublicKey (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)
+
+/-- `pk_0 || ... || pk_{v-1}`. -/
+def leafPayload (endpoints : ChainIndex → Digest) : HashInput :=
+  (List.ofFn endpoints).flatMap digestBytes
+
+/-- `X^{lay,tau}_{0,e}`, the one-time leaf: the hash of the `v` public values. -/
+def leafHash (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 (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 (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 (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 (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 -/
+
+/-- The two children of a Merkle node. -/
+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 (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)
+
+/-- `TreeRoot(P, lay, tau) = X^{lay,tau}_{h_lay, 0}`. -/
+def treeRoot (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 (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 (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 -/
+
+/-- A node index at level `0` read as a leaf index. -/
+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) : IndexGroup :=
+  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 lastIndexGroup : IndexGroup := ⟨ftsTrees - 1, by decide⟩
+
+/-- `Y^{idx,kappa}_{0,j}`, the hash of one few-time secret. -/
+def ftsLeafHash (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 (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)
+
+/-- The `k - 1` roots of the forest. -/
+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 (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 (parameter : PublicParameter) (index : Index) (leaves : IndexGroup → 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 (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 (parameter : PublicParameter) (index : Index) (leaves : IndexGroup → 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 -/
+
+/-- `rho || root || m`, what the message digest hashes after the tweak and the parameter. -/
+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 (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) : IndexGroup → 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 lastIndexGroup = 0
+
+instance (digest : MessageDigest) : Decidable (Admissible digest) :=
+  inferInstanceAs (Decidable (digestLeaves digest lastIndexGroup = 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 (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
+
+/-- `Ver(pk, m, sigma)`: recompute the digest, recover the few-time key, walk the layers and compare with the root. -/
+def verify (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)
+
+/-! ### Key generation
+
+Uniform sampling of the parameter, of every one-time secret, of every few-time secret and of a randomizer; `$ᵗ X` draws a uniform element of `X`. The two `opaque` wrappers only keep Lean from unfolding the samplers of the two large function types. -/
+
+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
+
+/-- Layer `0` holds one tree, at index `0`. -/
+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⟩)
+
+/-! ### Signing -/
+
+/-- One digest attempt: one hash, keeping the index and the leaf indices if the digest is admissible. -/
+def signAttempt (secretKey : SecretKey) (message : Message) (randomness : Randomness) :
+    m (Option (Index × (IndexGroup → 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 × (IndexGroup → 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 × (IndexGroup → 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 (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 (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
+
+/-- `Sig(sk, m)`: the digest loop, the few-time opening, one one-time signature per layer, and the assembled signature, or nothing as soon as one layer fails. -/
+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 sequenceFin (m := Option) 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] treeNode ftsNode verify sampleParameter sampleOtsSecrets sampleFtsSecrets
+  sampleRandomness keygen 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 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
+
+/-- A signing request is a message alone, the scheme being stateless, and the answer is a signature or `none` if the signer fails. -/
+abbrev SigningSpec := Message →ₒ 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 security claim: `127` bits of classical strong unforgeability in the random-oracle model, at `2^24` signing requests per key pair. -/
+abbrev SphincsSecurityStatement : Prop :=
+  HasClassicalSecurityBits Concrete.scheme 127
+
+end SphincsSecurity
diff --git a/formal/sphincs/lake-manifest.json b/formal/sphincs/lake-manifest.json
new file mode 100644
index 000000000..19314c3ca
--- /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 000000000..982fa1d28
--- /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 000000000..18640c8b0
--- /dev/null
+++ b/formal/sphincs/lean-toolchain
@@ -0,0 +1 @@
+leanprover/lean4:v4.31.0
diff --git a/formal/sphincs/scripts/Reach.lean b/formal/sphincs/scripts/Reach.lean
new file mode 100644
index 000000000..0ae7dba42
--- /dev/null
+++ b/formal/sphincs/scripts/Reach.lean
@@ -0,0 +1,44 @@
+import SphincsSecurity
+import Lean
+
+/-!
+Reachability audit. `lake env lean scripts/Reach.lean` writes `reach.txt`, one line per local declaration with its module, source line range and whether the proof terms of the public theorem reach it. Declarations that reachability cannot see but the elaborator needs (rfl simp lemmas, instances, names used only in simp lists) must be kept when pruning by hand.
+-/
+
+open Lean Elab Command in
+run_cmd do
+  let env ← getEnv
+  let roots : Array Name := #[``SphincsSecurity.sphincs_has_127_bits_of_classical_security]
+  let mut visited : NameSet := {}
+  let mut stack : Array Name := roots
+  while !stack.isEmpty do
+    let n := stack.back!
+    stack := stack.pop
+    if visited.contains n then continue
+    visited := visited.insert n
+    match env.find? n with
+    | none => pure ()
+    | some ci =>
+      for c in ci.type.getUsedConstants do
+        if !visited.contains c then stack := stack.push c
+      match ci.value? (allowOpaque := true) with
+      | some v =>
+        for c in v.getUsedConstants do
+          if !visited.contains c then stack := stack.push c
+      | none => pure ()
+  let mut out : String := ""
+  let mut total := 0
+  let mut reached := 0
+  for (name, _) in env.constants.toList do
+    let some index := env.getModuleIdxFor? name | continue
+    let moduleName := env.header.moduleNames[index.toNat]!
+    if !moduleName.toString.startsWith "SphincsSecurity" then continue
+    total := total + 1
+    let r := visited.contains name
+    if r then reached := reached + 1
+    let range ← match ← findDeclarationRanges? name with
+      | some rs => pure s!"{rs.range.pos.line}|{rs.range.endPos.line}"
+      | none => pure "-|-"
+    out := out ++ s!"{moduleName}|{name}|{range}|{if r then "1" else "0"}\n"
+  IO.FS.writeFile "reach.txt" out
+  logInfo m!"total {total} reached {reached}"
diff --git a/formal/sphincs/scripts/Taint.lean b/formal/sphincs/scripts/Taint.lean
new file mode 100644
index 000000000..04c6213e7
--- /dev/null
+++ b/formal/sphincs/scripts/Taint.lean
@@ -0,0 +1,88 @@
+import SphincsSecurity
+import Lean
+
+/-!
+Component dependency audit. `lake env lean scripts/Taint.lean` writes `taint.txt`, one line per local declaration with its module, the component-specific definitions of `Statement.lean` it references directly and the ones it reaches transitively, as bit sets: 1 the one-time signature, 2 the few-time signature, 4 the hypertree. A module whose transitive set never contains 1 is untouched by a change of the one-time signature.
+-/
+
+open Lean
+
+namespace TaintAudit
+
+def otsSeeds : Array Name := #[``SphincsSecurity.winternitzBits, ``SphincsSecurity.chainLength, ``SphincsSecurity.numChains,
+  ``SphincsSecurity.targetSum, ``SphincsSecurity.Digit, ``SphincsSecurity.ChainStep, ``SphincsSecurity.Encoding,
+  ``SphincsSecurity.TargetSum.sum, ``SphincsSecurity.TargetSum.Valid, ``SphincsSecurity.TargetSum.digitsPerHalf,
+  ``SphincsSecurity.TargetSum.digitOffset, ``SphincsSecurity.TargetSum.digestEncoding, ``SphincsSecurity.TargetSum.decodeDigest,
+  ``SphincsSecurity.encodingAttemptLimit, ``SphincsSecurity.HashDomain.chain, ``SphincsSecurity.HashDomain.encoding,
+  ``SphincsSecurity.Concrete.chainWalk, ``SphincsSecurity.Concrete.recoverChain, ``SphincsSecurity.Concrete.oneTimePublicKey,
+  ``SphincsSecurity.Concrete.encode, ``SphincsSecurity.Concrete.otsSignFrom, ``SphincsSecurity.Concrete.otsSign,
+  ``SphincsSecurity.Concrete.otsLeaf, ``SphincsSecurity.Concrete.leafPayload, ``SphincsSecurity.Concrete.leafHash]
+
+def ftsSeeds : Array Name := #[``SphincsSecurity.ftsTreeHeight, ``SphincsSecurity.ftsTrees, ``SphincsSecurity.FtsTree,
+  ``SphincsSecurity.IndexGroup, ``SphincsSecurity.FtsLeaf, ``SphincsSecurity.digestAttemptLimit, ``SphincsSecurity.HashDomain.ftsLeaf,
+  ``SphincsSecurity.HashDomain.ftsNode, ``SphincsSecurity.HashDomain.ftsRoots, ``SphincsSecurity.HashDomain.message,
+  ``SphincsSecurity.messageDigestBits, ``SphincsSecurity.MessageDigest, ``SphincsSecurity.truncateMessageDigest,
+  ``SphincsSecurity.Concrete.ftsLeafOfNat, ``SphincsSecurity.Concrete.ftsIndexOf, ``SphincsSecurity.Concrete.lastIndexGroup,
+  ``SphincsSecurity.Concrete.ftsLeafHash, ``SphincsSecurity.Concrete.ftsNode, ``SphincsSecurity.Concrete.ftsRootsPayload,
+  ``SphincsSecurity.Concrete.ftsKey, ``SphincsSecurity.Concrete.ftsOpen, ``SphincsSecurity.Concrete.ftsFold,
+  ``SphincsSecurity.Concrete.ftsRecover, ``SphincsSecurity.Concrete.messageDigestPayload, ``SphincsSecurity.Concrete.messageDigest,
+  ``SphincsSecurity.Concrete.digestIndex, ``SphincsSecurity.Concrete.digestLeaves, ``SphincsSecurity.Concrete.Admissible,
+  ``SphincsSecurity.Concrete.signAttempt, ``SphincsSecurity.Concrete.signDigestLoop]
+
+def treeSeeds : Array Name := #[``SphincsSecurity.numLayers, ``SphincsSecurity.totalHeight, ``SphincsSecurity.maxLayerHeight,
+  ``SphincsSecurity.PathIndex, ``SphincsSecurity.layerHeight, ``SphincsSecurity.topLayer, ``SphincsSecurity.middleLayer,
+  ``SphincsSecurity.bottomLayer, ``SphincsSecurity.heightAbove, ``SphincsSecurity.heightBelow, ``SphincsSecurity.HashDomain.leaf,
+  ``SphincsSecurity.HashDomain.node, ``SphincsSecurity.Concrete.treeIndexAt, ``SphincsSecurity.Concrete.leafIndexAt,
+  ``SphincsSecurity.Concrete.leafOfNat, ``SphincsSecurity.Concrete.nodePayload, ``SphincsSecurity.Concrete.treeNode,
+  ``SphincsSecurity.Concrete.treeRoot, ``SphincsSecurity.Concrete.treePath, ``SphincsSecurity.Concrete.treeFold,
+  ``SphincsSecurity.Concrete.signaturePath, ``SphincsSecurity.Concrete.verifyLayers, ``SphincsSecurity.Concrete.layerMessage,
+  ``SphincsSecurity.Concrete.signLayer, ``SphincsSecurity.Concrete.layerOfPath, ``SphincsSecurity.Concrete.flattenPaths,
+  ``SphincsSecurity.Concrete.rootTree]
+
+def tagOf (n : Name) : Nat :=
+  (if otsSeeds.contains n then 1 else 0) + (if ftsSeeds.contains n then 2 else 0) + (if treeSeeds.contains n then 4 else 0)
+
+def isLocal (env : Environment) (n : Name) : Bool :=
+  match env.getModuleIdxFor? n with
+  | some j => (env.header.moduleNames[j.toNat]!).toString.startsWith "SphincsSecurity"
+  | none => false
+
+def usedOf (ci : ConstantInfo) : Array Name :=
+  let a := ci.type.getUsedConstants
+  match ci.value? (allowOpaque := true) with
+  | some v => a ++ v.getUsedConstants
+  | none => a
+
+partial def trans (env : Environment) (memo : IO.Ref (Std.HashMap Name Nat)) (n : Name) : IO Nat := do
+  if let some t := (← memo.get).get? n then return t
+  -- provisional entry breaks cycles through auxiliary definitions
+  memo.modify (·.insert n (tagOf n))
+  let mut t := tagOf n
+  if let some ci := env.find? n then
+    for c in usedOf ci do
+      if isLocal env c then
+        t := t ||| (← trans env memo c)
+      else
+        t := t ||| tagOf c
+  memo.modify (·.insert n t)
+  return t
+
+end TaintAudit
+
+open TaintAudit Elab Command in
+run_cmd do
+  let env ← getEnv
+  for n in otsSeeds ++ ftsSeeds ++ treeSeeds do
+    if (env.find? n).isNone then logWarning m!"unknown seed {n}"
+  let memo ← IO.mkRef ({} : Std.HashMap Name Nat)
+  let mut out : String := ""
+  for (n, ci) in env.constants.toList do
+    if !isLocal env n then continue
+    let some j := env.getModuleIdxFor? n | continue
+    let m := env.header.moduleNames[j.toNat]!
+    let mut direct := 0
+    for c in usedOf ci do direct := direct ||| tagOf c
+    let t ← trans env memo n
+    out := out ++ s!"{m}|{n}|{direct}|{t}\n"
+  IO.FS.writeFile "taint.txt" out
+  logInfo "done"
diff --git a/formal/xmss/XmssSecurity/Statement.lean b/formal/xmss/XmssSecurity/Statement.lean
index d9bcb544c..fe92c9344 100644
--- a/formal/xmss/XmssSecurity/Statement.lean
+++ b/formal/xmss/XmssSecurity/Statement.lean
@@ -21,7 +21,9 @@ def hashOutputBits : Nat := 256
 def messageBits : Nat := 256
 def publicParameterBits : Nat := 128
 def randomnessBits : Nat := 192
+/-- Encoding attempts per signature, `A_max`. -/
 def signingAttemptLimit : Nat := 2 ^ 23
+/-- The Merkle tree height `h`; the lifetime is `L = 2^h` epochs. -/
 def treeHeight : Nat := 32
 def lifetime : Nat := 2 ^ treeHeight
 def winternitzBits : Nat := 3
@@ -34,29 +36,39 @@ abbrev HashOutput := BitVec hashOutputBits
 abbrev Message := BitVec messageBits
 abbrev PublicParameter := BitVec publicParameterBits
 abbrev Randomness := BitVec randomnessBits
+/-- `ep < L`. -/
 abbrev Epoch := Fin lifetime
 abbrev ChainIndex := Fin numChains
 abbrev Digit := Fin chainLength
+/-- A chain step; the tweak carries `2^w * i + step`. -/
+abbrev ChainStep := Fin (chainLength - 1)
+/-- A level of the stored tree, `0` the leaves and `h` the root. -/
 abbrev MerkleHeight := Fin (treeHeight + 1)
+/-- A level of the authentication path, below the root; the tweak carries `level + 1`. -/
+abbrev MerkleLevel := Fin treeHeight
+/-- A node within a level. Level `ℓ` only uses the values below `2^(h - ℓ)`. -/
 abbrev MerkleNode := Fin lifetime
 abbrev Encoding := ChainIndex → Digit
 abbrev HashInput := List UInt8
 
-/-- Keep the first 128 output bits, represented as the low bits of the little-endian bit vector. -/
+/-- Keep the first 128 output bits, the low bits of the little-endian bit vector. -/
 def truncateHash (output : HashOutput) : Digest :=
   output.extractLsb' 0 digestBits
 
+/-- `pk = (root, P)`. -/
 structure PublicKey where
   root : Digest
   parameter : PublicParameter
 deriving DecidableEq
 
+/-- The ideal precomputed key of the specification: `P`, the sampled `sk_{ep,i}`, every chain value `C_{ep,i,k}` and every Merkle node `X_{ℓ,j}`. -/
 structure SecretKey where
   parameter : PublicParameter
   chainStart : Epoch → ChainIndex → Digest
   chainValue : Epoch → ChainIndex → Digit → Digest
   treeValue : MerkleHeight → MerkleNode → Digest
 
+/-- `sigma = (rho, sigma_OTS, path_ep)`: the encoding randomness, the `v` chain values and the `h` authentication nodes. -/
 structure Signature where
   randomness : Randomness
   chainValue : ChainIndex → Digest
@@ -68,6 +80,7 @@ def bytesLE (byteCount : Nat) (value : BitVec (8 * byteCount)) : List UInt8 :=
   List.ofFn fun index : Fin byteCount =>
     UInt8.ofBitVec (value.extractLsb' (8 * index.val) 8)
 
+/-- The three fields of the specification's `enc(t, p, j)`. -/
 structure TweakFields where
   tag : BitVec 8
   position : BitVec 32
@@ -79,10 +92,7 @@ def fieldBytes (fields : TweakFields) : List UInt8 :=
   bytesLE 1 fields.tag ++ bytesLE 4 fields.position ++ bytesLE 4 fields.epoch ++
     List.replicate 7 0
 
-abbrev ChainStep := Fin (chainLength - 1)
-abbrev MerkleLevel := Fin treeHeight
-
-/-- Every domain-separated hash call made by the concrete XMSS instance. -/
+/-- Every domain-separated hash call the instance makes, tweak types `0` to `3`. -/
 inductive HashDomain where
   | chain (epoch : Epoch) (chain : ChainIndex) (step : ChainStep)
   | leaf (epoch : Epoch)
@@ -90,7 +100,7 @@ inductive HashDomain where
   | encoding (epoch : Epoch)
 deriving DecidableEq
 
-/-- Serialize a typed hash domain into the fields of an XMSS tweak. -/
+/-- Serialize a typed hash domain into the fields of a tweak. -/
 def hashDomainFields : HashDomain → TweakFields
   | .chain epoch chain step =>
       ⟨0#8, BitVec.ofNat 32 (chainLength * chain.val + step.val), BitVec.ofNat 32 epoch.val⟩
@@ -108,21 +118,29 @@ 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 = 195`. -/
+
 namespace TargetSum
 
+/-- The digit sum of a word. -/
 def sum (x : Encoding) : Nat := ∑ i, (x i).val
 
+/-- Membership in the code `C`: digit sum `T`. -/
 def Valid (x : Encoding) : Prop := sum x = targetSum
 
 instance : DecidablePred Valid :=
   fun x => inferInstanceAs (Decidable (sum x = targetSum))
 
+/-- `v / 2 = 21` digits in each half of the digest. -/
 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
 
+/-- `x_i`, the three bits of the digest at the digit's offset. -/
 def digestEncoding (digest : Digest) : Encoding :=
   fun i => (digest.extractLsb' (digitOffset i) winternitzBits).toFin
 
@@ -135,11 +153,7 @@ end TargetSum
 
 /-! ## The algorithms
 
-The three algorithms of the scheme, exactly as run in the security experiment: key generation, signing, and verification, together with the oracle hash calls they make.
-
-The secret key is the ideal precomputed key from the specification: it contains every Winternitz chain value and every Merkle node. `Concrete.precomputedKeygen` obtains those values through the random oracle by computing the Merkle root, then stores them as the pure replay of its own query log: each stored table entry is the same oracle computation evaluated again, with every hash query answered from the recorded cache (`replayHash`). Reading them while signing is local computation and therefore does not count as a random-oracle query. `Concrete.precomputedCappedSign` performs at most `2^23` encoding attempts, each sampling 192 fresh bits and querying the random oracle once; `Concrete.verify` is the ordinary XMSS verifier.
-
-The `irreducible` attributes in this section only seal definitions against accidental unfolding in proofs; they change no definition. Lean restricts global reducibility attributes to the defining module, so they must appear here. -/
+Key generation, signing and verification as run in the experiment, with every oracle hash call they make. Everything under `Concrete` is the instance; the experiment after it is generic over `Scheme`. The hashing algorithms are written for any monad `m` that can query the hash, and key generation and signing run them with `liftM` inside the world that also samples. Key generation computes the Merkle root through the oracle and stores every chain value and node as the replay of that computation against its own query log, so reading them while signing is not an oracle query; signing makes at most `signingAttemptLimit` encoding attempts, each sampling fresh randomness and hashing once; verification is the ordinary verifier. Branches that return `0` out of range exist only to make the definitions total; the honest algorithms never take them and verification never reads them. The `irreducible` attributes at the end of the namespace only seal definitions against accidental unfolding in proofs, and Lean restricts global reducibility attributes to the defining module. -/
 
 /-- A hash query takes an arbitrary byte string and returns 32 bytes. -/
 abbrev HashSpec := HashInput →ₒ HashOutput
@@ -147,83 +161,90 @@ abbrev HashSpec := HashInput →ₒ HashOutput
 /-- `unifSpec` for uniform sampling, `HashSpec` for the random oracle (hash). A query is `.inl` to sample or `.inr` to hash, so `HasHashQueryBound` counts only the hash side. -/
 abbrev OracleWorld := unifSpec + HashSpec
 
+/-- Enter a query log into a cache, in order. -/
 def extendHashCacheWithLog (initialCache : QueryCache HashSpec) :
     QueryLog HashSpec → QueryCache HashSpec
   | [] => initialCache
   | ⟨input, output⟩ :: tail =>
       extendHashCacheWithLog (initialCache.cacheQuery input output) tail
 
+/-- The cache a query log records. -/
 def hashCacheOfLog (log : QueryLog HashSpec) : QueryCache HashSpec :=
   extendHashCacheWithLog ∅ log
 
 namespace Concrete
 
-def digestBytes (value : Digest) : HashInput :=
-  bytesLE 16 value
+def digestBytes (value : Digest) : HashInput := bytesLE 16 value
 
-def messageBytes (message : Message) : HashInput :=
-  bytesLE 32 message
+def messageBytes (message : Message) : HashInput := bytesLE 32 message
 
-def randomnessBytes (randomness : Randomness) : HashInput :=
-  bytesLE 24 randomness
+def randomnessBytes (randomness : Randomness) : HashInput := bytesLE 24 randomness
 
+/-- `m || rho || 0^64`. -/
 def encodingPayload (message : Message) (randomness : Randomness) : HashInput :=
   messageBytes message ++ randomnessBytes randomness ++ List.replicate 8 0
 
+/-- `pk_0 || ... || pk_{v-1}`. -/
 def leafPayload (endpoints : ChainIndex → Digest) : HashInput :=
   (List.ofFn endpoints).flatMap digestBytes
 
+/-- The two children of a Merkle node. -/
 def nodePayload (left right : Digest) : HashInput :=
   digestBytes left ++ digestBytes right
 
-def oracleHash {m : Type → Type} [Monad m] [HasQuery HashSpec m]
-    (input : HashInput) : m HashOutput :=
+/-- Run the `n` computations in index order and collect their results. -/
+def sequenceFin {m : Type → Type} [Monad m] {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
+
+variable {m : Type → Type} [Monad m] [HasQuery HashSpec m]
+
+/-- One query to the random oracle `H`. -/
+def oracleHash (input : HashInput) : m HashOutput :=
   HasQuery.query (spec := HashSpec) (m := m) input
 
-def tweakableHash {m : Type → Type} [Monad m] [HasQuery HashSpec m]
+/-- `Th(P, tw, M) = Truncate_n(H(tw || P || M))`. -/
+def tweakableHash
     (parameter : PublicParameter) (domain : HashDomain) (payload : HashInput) : m Digest := do
   let output ← oracleHash (tweakableHashInput parameter domain payload)
   return truncateHash output
 
-def encodingHash {m : Type → Type} [Monad m] [HasQuery HashSpec m]
-    (parameter : PublicParameter) (epoch : Epoch)
+/-- The digest `D` of `IncEnc(P, m, rho, ep)`. -/
+def encodingHash (parameter : PublicParameter) (epoch : Epoch)
     (message : Message) (randomness : Randomness) : m Digest :=
   tweakableHash parameter (.encoding epoch) (encodingPayload message randomness)
 
-def chainHash {m : Type → Type} [Monad m] [HasQuery HashSpec m]
-    (parameter : PublicParameter) (epoch : Epoch) (chain : ChainIndex)
+/-- One chain step, under `tweak_chain(ep, i, step + 1)`. -/
+def chainHash (parameter : PublicParameter) (epoch : Epoch) (chain : ChainIndex)
     (step : ChainStep) (value : Digest) : m Digest :=
   tweakableHash parameter (.chain epoch chain step) (digestBytes value)
 
-def leafHash {m : Type → Type} [Monad m] [HasQuery HashSpec m]
-    (parameter : PublicParameter) (epoch : Epoch)
+/-- `X_{0,ep}`, the hash of the `v` public values. -/
+def leafHash (parameter : PublicParameter) (epoch : Epoch)
     (endpoints : ChainIndex → Digest) : m Digest :=
   tweakableHash parameter (.leaf epoch) (leafPayload endpoints)
 
-def nodeHash {m : Type → Type} [Monad m] [HasQuery HashSpec m]
-    (parameter : PublicParameter) (level : MerkleLevel) (node : MerkleNode)
+/-- `X_{level+1,node}` from its two children. -/
+def nodeHash (parameter : PublicParameter) (level : MerkleLevel) (node : MerkleNode)
     (left right : Digest) : m Digest :=
   tweakableHash parameter (.merkle level node) (nodePayload left right)
 
-/-! Verification. -/
+/-! ### Verification -/
 
+/-- `A_level`, or `0` above the tree. -/
 def signaturePath (signature : Signature) (level : Nat) : Digest :=
   if hlevel : level < treeHeight then
     signature.authPath ⟨level, hlevel⟩
   else
     0
 
-def sequenceFin {m : Type → Type} [Monad m] {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
-
-def chainWalk {m : Type → Type} [Monad m] [HasQuery HashSpec m]
-    (parameter : PublicParameter) (epoch : Epoch) (chain : ChainIndex) :
+/-- `Chain_{i,ep}(P, start, steps, value)`: the step onto position `start + steps + 1` carries tweak position `2^w * i + start + steps`. -/
+def chainWalk (parameter : PublicParameter) (epoch : Epoch) (chain : ChainIndex) :
     Nat → Nat → Digest → m Digest
   | _, 0, value => pure value
   | position, steps + 1, value => do
@@ -233,13 +254,13 @@ def chainWalk {m : Type → Type} [Monad m] [HasQuery HashSpec m]
       else
         pure 0
 
-def recoverChain {m : Type → Type} [Monad m] [HasQuery HashSpec m]
-    (parameter : PublicParameter) (epoch : Epoch) (chain : ChainIndex)
+/-- The verifier's half of a chain: walk the remaining `2^w - 1 - x_i` steps. -/
+def recoverChain (parameter : PublicParameter) (epoch : Epoch) (chain : ChainIndex)
     (digit : Digit) (value : Digest) : m Digest :=
   chainWalk parameter epoch chain digit.val (chainLength - 1 - digit.val) value
 
-def recoverEndpoints {m : Type → Type} [Monad m] [HasQuery HashSpec m]
-    (parameter : PublicParameter) (epoch : Epoch)
+/-- `pk'_{ep,i}` for every chain. -/
+def recoverEndpoints (parameter : PublicParameter) (epoch : Epoch)
     (encoding : Encoding) (signature : Signature) :
     m (ChainIndex → Digest) :=
   sequenceFin fun chain =>
@@ -251,8 +272,8 @@ def nodeIndex (epoch : Epoch) (level : Nat) : MerkleNode :=
     have hle := Nat.div_le_self epoch.val (2 ^ (level + 1))
     exact hle.trans_lt epoch.isLt⟩
 
-def authenticationNodeHash {m : Type → Type} [Monad m] [HasQuery HashSpec m]
-    (parameter : PublicParameter) (epoch : Epoch)
+/-- `Z_{level+1}` from `Z_level` and `A_level`, in the order bit `level` of the epoch dictates. -/
+def authenticationNodeHash (parameter : PublicParameter) (epoch : Epoch)
     (level : Nat) (current sibling : Digest) : m Digest :=
   if hlevel : level < treeHeight then
     if epoch.val.testBit level then
@@ -262,23 +283,22 @@ def authenticationNodeHash {m : Type → Type} [Monad m] [HasQuery HashSpec m]
   else
     pure 0
 
-def authenticationRoot {m : Type → Type} [Monad m] [HasQuery HashSpec m]
-    (parameter : PublicParameter) (epoch : Epoch)
+/-- `Z_levels`, folded up from the leaf `Z_0`. -/
+def authenticationRoot (parameter : PublicParameter) (epoch : Epoch)
     (signature : Signature) : Nat → Digest → m Digest
   | 0, leaf => pure leaf
   | levels + 1, leaf => do
       let current ← authenticationRoot parameter epoch signature levels leaf
       authenticationNodeHash parameter epoch levels current (signaturePath signature levels)
 
-def verifyAfterLeaf {m : Type → Type} [Monad m] [HasQuery HashSpec m]
+/-- Accept exactly when `Z_h = root`. -/
+def verifyAfterLeaf
     (publicKey : PublicKey) (epoch : Epoch) (signature : Signature) (leaf : Digest) : m Bool := do
   let root ← authenticationRoot publicKey.parameter epoch signature treeHeight leaf
   return decide (root = publicKey.root)
 
-attribute [irreducible] verifyAfterLeaf
-
-def verify {m : Type → Type} [Monad m] [HasQuery HashSpec m]
-    (publicKey : PublicKey) (epoch : Epoch)
+/-- `Ver(pk, ep, m, sigma)`. -/
+def verify (publicKey : PublicKey) (epoch : Epoch)
     (message : Message) (signature : Signature) : m Bool := do
   let digest ← encodingHash publicKey.parameter epoch message signature.randomness
   match TargetSum.decodeDigest digest with
@@ -288,7 +308,9 @@ def verify {m : Type → Type} [Monad m] [HasQuery HashSpec m]
       let leaf ← leafHash publicKey.parameter epoch endpoints
       verifyAfterLeaf publicKey epoch signature leaf
 
-/-! Key generation. -/
+/-! ### Key generation
+
+Uniform sampling of the parameter and of every one-time secret; `$ᵗ X` draws a uniform element of `X`. -/
 
 noncomputable local instance : SampleableType PublicParameter :=
   SampleableType.ofFintype PublicParameter
@@ -296,27 +318,29 @@ noncomputable local instance : SampleableType PublicParameter :=
 noncomputable local instance : SampleableType (Epoch → ChainIndex → Digest) :=
   SampleableType.ofFintype (Epoch → ChainIndex → Digest)
 
-def oneTimePublicKey {m : Type → Type} [Monad m] [HasQuery HashSpec m]
-    (parameter : PublicParameter) (secret : Epoch → ChainIndex → Digest)
+/-- `pk_{ep,i} = Chain(P, 0, 2^w - 1, sk_{ep,i})` for every chain. -/
+def oneTimePublicKey (parameter : PublicParameter) (secret : Epoch → ChainIndex → Digest)
     (epoch : Epoch) : m (ChainIndex → Digest) :=
   sequenceFin fun chain =>
     chainWalk parameter epoch chain 0 (chainLength - 1) (secret epoch chain)
 
-def leafAt {m : Type → Type} [Monad m] [HasQuery HashSpec m]
-    (parameter : PublicParameter) (secret : Epoch → ChainIndex → Digest)
+/-- `X_{0,ep}` from the secrets. -/
+def leafAt (parameter : PublicParameter) (secret : Epoch → ChainIndex → Digest)
     (epoch : Epoch) : m Digest := do
   let endpoints ← oneTimePublicKey parameter secret epoch
   leafHash parameter epoch endpoints
 
+/-- A natural read as a node index. -/
 def merkleNodeOfNat (value : Nat) : MerkleNode :=
   ⟨value % lifetime,
     Nat.mod_lt _ (by simp [lifetime])⟩
 
+/-- `2j` or `2j + 1`. -/
 def childNode (node : MerkleNode) (right : Bool) : MerkleNode :=
   merkleNodeOfNat (2 * node.val + if right then 1 else 0)
 
-def treeNode {m : Type → Type} [Monad m] [HasQuery HashSpec m]
-    (parameter : PublicParameter) (secret : Epoch → ChainIndex → Digest) :
+/-- `X_{levels,node}`, the Merkle tree over the one-time leaves. -/
+def treeNode (parameter : PublicParameter) (secret : Epoch → ChainIndex → Digest) :
     Nat → MerkleNode → m Digest
   | 0, node => leafAt parameter secret node
   | levels + 1, node => do
@@ -327,8 +351,7 @@ def treeNode {m : Type → Type} [Monad m] [HasQuery HashSpec m]
       else
         pure 0
 
-attribute [irreducible] treeNode
-
+/-- The root is node `0` of level `h`. -/
 def rootNode : MerkleNode :=
   ⟨0, by simp [lifetime]⟩
 
@@ -338,8 +361,6 @@ noncomputable def samplePublicParameter : ProbComp PublicParameter :=
 noncomputable def sampleSecret : ProbComp (Epoch → ChainIndex → Digest) :=
   $ᵗ (Epoch → ChainIndex → Digest)
 
-attribute [irreducible] samplePublicParameter sampleSecret
-
 /-- Answer a hash query from a recorded query cache, and by 0 for an unrecorded input. -/
 def replayHash (cache : QueryCache HashSpec) : QueryImpl HashSpec Id :=
   fun input => (cache input).getD 0
@@ -358,6 +379,7 @@ def precomputedSecretKey (parameter : PublicParameter)
     evalWithAnswerFn (replayHash cache)
       (treeNode parameter secret height.val node : OracleComp HashSpec Digest)
 
+/-- `Gen`: sample the parameter and the secrets, compute the root through the oracle, and store every chain value and node as the replay of that computation. -/
 noncomputable def precomputedKeygen :
     OracleComp OracleWorld (PublicKey × SecretKey) := do
   let parameter ← liftM samplePublicParameter
@@ -368,36 +390,37 @@ noncomputable def precomputedKeygen :
   let cache := hashCacheOfLog result.2
   return (⟨result.1, parameter⟩, precomputedSecretKey parameter secret cache)
 
-attribute [irreducible] precomputedKeygen
-
-/-! Signing. -/
+/-! ### Signing -/
 
 noncomputable local instance : SampleableType Randomness :=
   SampleableType.ofFintype Randomness
 
+/-- `rho`, fresh per attempt. -/
 noncomputable def signingRandomness : ProbComp Randomness :=
   $ᵗ Randomness
 
-attribute [irreducible] signingRandomness
-
+/-- `floor(ep / 2^level) xor 1`, the sibling on the path. -/
 def authenticationPathNode (epoch : Epoch) (level : MerkleLevel) : MerkleNode :=
   merkleNodeOfNat (Nat.xor (epoch.val / 2 ^ level.val) 1)
 
+/-- `sigma_OTS,i = C_{ep,i,x_i}`. -/
 def precomputedSignedChainValues (secretKey : SecretKey) (epoch : Epoch)
     (encoding : Encoding) : ChainIndex → Digest :=
   fun chain => secretKey.chainValue epoch chain (encoding chain)
 
+/-- `path_ep = (A_0, ..., A_{h-1})`, read from the stored tree. -/
 def precomputedAuthenticationPath (secretKey : SecretKey) (epoch : Epoch) :
     Fin treeHeight → Digest :=
   fun level => secretKey.treeValue level.castSucc (authenticationPathNode epoch level)
 
+/-- The signature once the encoding is found. -/
 def precomputedSignWithEncoding (secretKey : SecretKey) (epoch : Epoch)
     (randomness : Randomness) (encoding : Encoding) : Signature :=
   ⟨randomness, precomputedSignedChainValues secretKey epoch encoding,
     precomputedAuthenticationPath secretKey epoch⟩
 
-def precomputedSignAttempt {m : Type → Type} [Monad m]
-    [HasQuery HashSpec m] (secretKey : SecretKey) (epoch : Epoch)
+/-- One attempt: hash once, and sign if the digest encodes. -/
+def precomputedSignAttempt (secretKey : SecretKey) (epoch : Epoch)
     (message : Message) (randomness : Randomness) : m (Option Signature) := do
   let digest ← encodingHash secretKey.parameter epoch message randomness
   match TargetSum.decodeDigest digest with
@@ -405,6 +428,7 @@ def precomputedSignAttempt {m : Type → Type} [Monad m]
   | some encoding =>
       pure (some (precomputedSignWithEncoding secretKey epoch randomness encoding))
 
+/-- At most `attempts` attempts, each with fresh randomness, stopping at the first that encodes. -/
 noncomputable def precomputedSignBoundedAttempts :
     Nat → SecretKey → Epoch → Message →
       OracleComp OracleWorld (Option Signature)
@@ -418,12 +442,14 @@ noncomputable def precomputedSignBoundedAttempts :
       | some signature => pure (some signature)
       | none => precomputedSignBoundedAttempts attempts secretKey epoch message
 
+/-- `Sig(sk, ep, m)`, at most `A_max` attempts. The once-per-epoch discipline is the game's, in `SigningTranscript.Valid`. -/
 noncomputable def precomputedCappedSign (secretKey : SecretKey)
     (epoch : Epoch) (message : Message) :
     OracleComp OracleWorld (Option Signature) :=
   precomputedSignBoundedAttempts signingAttemptLimit secretKey epoch message
 
-attribute [irreducible] precomputedCappedSign
+attribute [irreducible] verifyAfterLeaf treeNode samplePublicParameter sampleSecret
+  precomputedKeygen signingRandomness precomputedCappedSign
 
 end Concrete
 
@@ -447,6 +473,7 @@ structure Forgery where
   signature : Signature
 deriving DecidableEq
 
+/-- The request a forgery claims to answer. -/
 def Forgery.request (forgery : Forgery) : SignRequest :=
   ⟨forgery.epoch, forgery.message⟩
 
@@ -523,7 +550,7 @@ noncomputable def Concrete.scheme : Scheme where
   verify := fun publicKey epoch message signature =>
     liftM (Concrete.verify publicKey epoch message signature : OracleComp HashSpec Bool)
 
-/-- The complete public security claim. -/
+/-- The security claim: `127` bits of classical strong unforgeability in the random-oracle model. -/
 abbrev XmssSecurityStatement : Prop :=
   HasClassicalSecurityBits Concrete.scheme 127