S3/L4-L5: root binding (Lemma 2, Path instance) + Theorem 2, constructive

The crux layer — the statement whose HAND proof once carried the frontier
coverage bug is now kernel-checked.

- gen: hash outputs refactored to Hash = {l : List UInt8 // l.length = 32}.
  MECHANIZATION FINDING: the paper's pair-coincidence step ('equal hnode
  values of distinct argument pairs are a collision') is load-bearing on
  FIXED-WIDTH outputs — with unconstrained byte strings x++s = X++Y does
  not split. hnode_preimage_inj (cone: propext) makes this explicit via
  List.append_inj on equal-length components. Queued as a half-sentence
  for the paper's next cycle.
- HasCollision := ∃ x y, x ≠ y ∧ sha256 x = sha256 y — appears ONLY as a
  conclusion, never a hypothesis (no collision-resistance assumed).
- hnode_inj_or_collision / hleaf_inj_or_collision: the per-node dichotomy.
- root_binding: any accepting reconstruction from (v,P) to the honest root
  either IS the honest receipt (leaf hash AND full path P = Path m D — case
  (ii) pinning every consumed sibling) or exhibits a collision. Motive
  quantifies (v,P); induction on Path; k-fold discipline.
- incl_sound (Theorem 2, position binding): accepting a wrong leaf at m
  yields a collision. Cone [propext, Classical.choice, LTLAcc.sha256,
  Quot.sound] — the single hash axiom, pinned in check.sh. ALL GREEN.

Also: Root n=1 branch changed from list-match to decidable 'if P = []'
(well-founded unfolding generated a spurious exhaustiveness obligation);
Root_one_cons added. Fable-5 statement-audit passed. LTL untouched.

Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>

README.md

@@ -12,8 +12,8 @@ the same discipline as the four `*-ed25519-verified` subject corpora.
 | L1 | bytes, hleaf/hnode, domain separation (Lemma 1) | **done** (domsep: axiom-free) |
 | L2 | MTH, Root, ConsRec definitions + termination | **done** (cones: propext, LTLAcc.sha256, Quot.sound) |
 | L3 | inclusion completeness (Theorem 1) | **done** (incl_complete: propext, Classical.choice, LTLAcc.sha256, Quot.sound) |
-| L4 | frontier hash-fold + root binding (Lemma 2) | pending |
-| L5 | inclusion/consistency soundness as collision extractors (Theorems 2, 3) | pending |
+| L4 | root binding for inclusion (Lemma 2, Path instance) | **done** (root_binding; boundary = single sha256 axiom) |
+| L5 | inclusion soundness = collision extractor (Theorem 2) **done**; consistency (Theorem 3) pending |
 | L6 | pin-store state machine safety (Proposition 1) | pending |
 
 ## Discipline (identical to the subject corpora)

verification/Proofs/AxiomCheck.lean

@@ -1,6 +1,7 @@
 /- Axiom-cone observation for the audit (Phase 3 of check.sh). -/
 import Proofs.Basic
 import Proofs.Completeness
+import Proofs.Binding
 #print axioms LTLAcc.domsep
 #print axioms LTLAcc.kbelow_pos
 #print axioms LTLAcc.kbelow_lt
@@ -11,3 +12,8 @@ import Proofs.Completeness
 #print axioms LTLAcc.ConsRec
 #print axioms LTLAcc.Path
 #print axioms LTLAcc.incl_complete
+#print axioms LTLAcc.hnode_preimage_inj
+#print axioms LTLAcc.hnode_inj_or_collision
+#print axioms LTLAcc.hleaf_inj_or_collision
+#print axioms LTLAcc.root_binding
+#print axioms LTLAcc.incl_sound

verification/Proofs/Basic.lean

@@ -11,10 +11,22 @@ namespace LTLAcc
 abbrev Bytes := List UInt8
 
 /-- Leaf hash: `H(0x00 ‖ d)` (paper §5.3). -/
-noncomputable def hleaf (d : Bytes) : Bytes := sha256 (0x00 :: d)
+noncomputable def hleaf (d : Bytes) : Hash := sha256 (0x00 :: d)
 
-/-- Node hash: `H(0x01 ‖ x ‖ y)` (paper §5.3). -/
-noncomputable def hnode (x y : Bytes) : Bytes := sha256 (0x01 :: (x ++ y))
+/-- Node hash: `H(0x01 ‖ x ‖ y)` (paper §5.3). Arguments are 32-byte
+    hash values, so the preimage determines the argument pair — the
+    load-bearing width fact of the paper's Lemma 2. -/
+noncomputable def hnode (x y : Hash) : Hash := sha256 (0x01 :: (x.val ++ y.val))
+
+/-- Preimage-level pair injectivity: equal `hnode` PREIMAGES force equal
+    argument pairs, because both components are exactly 32 bytes. -/
+theorem hnode_preimage_inj {x y X Y : Hash}
+    (h : (0x01 : UInt8) :: (x.val ++ y.val) = 0x01 :: (X.val ++ Y.val)) :
+    x = X ∧ y = Y := by
+  injection h with _ happ
+  have hlen : x.val.length = X.val.length := by rw [x.property, X.property]
+  have := List.append_inj happ hlen
+  exact ⟨Subtype.ext this.1, Subtype.ext this.2⟩
 
 /-- **Lemma 1 (Domain separation), preimage form**: no leaf preimage
     equals a node preimage as a byte string — the first byte differs. -/
@@ -74,7 +86,7 @@ theorem kbelow_pow2 (n : Nat) : ∃ j, kbelow n = 2 ^ j := by
 /-- `MTH` (paper §5.3): the RFC 9162 tree head over a leaf-data list.
     `MTH [] = H(ε)`, `MTH [d] = hleaf d`, and for `n ≥ 2` the split at
     `k = kbelow n`. -/
-noncomputable def MTH (D : List Bytes) : Bytes :=
+noncomputable def MTH (D : List Bytes) : Hash :=
   if _h0 : D.length = 0 then sha256 []
   else if _h1 : D.length = 1 then hleaf (D.headD [])
   else
@@ -95,11 +107,9 @@ decreasing_by
 
 /-- `Root` (paper §5.3 / Appendix B): the consumer's root reconstruction.
     `none` = rejection on any length mismatch, exactly as deployed. -/
-noncomputable def Root (v : Bytes) (m n : Nat) (P : List Bytes) : Option Bytes :=
+noncomputable def Root (v : Hash) (m n : Nat) (P : List Hash) : Option Hash :=
   if n = 1 then
-    match P with
-    | [] => some v
-    | _ => none
+    (if P = [] then some v else none)
   else if n = 0 then none
   else
     match P.getLast? with
@@ -125,8 +135,8 @@ decreasing_by
     the reconstructed pair (old root, new root); `none` = shape
     mismatch. The flag `b` records whether the size-`n₀` subtree root is
     carried implicitly (the pinned root `r`) or explicitly in `C`. -/
-noncomputable def ConsRec (n₀ n : Nat) (C : List Bytes) (b : Bool) (r : Bytes) :
-    Option (Bytes × Bytes) :=
+noncomputable def ConsRec (n₀ n : Nat) (C : List Hash) (b : Bool) (r : Hash) :
+    Option (Hash × Hash) :=
   if n₀ = n then
     if b then
       match C with
@@ -159,7 +169,7 @@ decreasing_by
 
 /-- The consumer's acceptance predicate for a consistency proof between
     pinned head `(n₀, r₀)` and offered head `(n₁, r₁)` (paper §5.3). -/
-def acceptCons (n₀ n₁ : Nat) (r₀ r₁ : Bytes) (C : List Bytes) : Prop :=
+def acceptCons (n₀ n₁ : Nat) (r₀ r₁ : Hash) (C : List Hash) : Prop :=
   n₀ = 0 ∨ ConsRec n₀ n₁ C true r₀ = some (r₀, r₁)
 
 end LTLAcc

verification/Proofs/Binding.lean

@@ -0,0 +1,185 @@
+/- L4 (first instance) of the accumulator pyramid: **root binding for the
+   inclusion fold** — the Path instance of the paper's Lemma 2 — and
+   **Theorem 2 (inclusion soundness)** as a constructive statement:
+   an accepting receipt for a wrong leaf EXHIBITS a SHA-256 collision.
+
+   No collision-resistance assumption appears anywhere: `HasCollision`
+   is the conclusion, never a hypothesis. -/
+import Proofs.Completeness
+
+namespace LTLAcc
+
+/-- Two distinct preimages with equal hash — the jackpot. Constructively
+    exhibited by the soundness theorems; believing it cannot be found is
+    the reader's interpretation of SHA-256, exactly as in the paper. -/
+def HasCollision : Prop :=
+  ∃ x y : List UInt8, x ≠ y ∧ sha256 x = sha256 y
+
+/-- Either two hash values have equal preimage pairs, or their equality
+    is itself a collision (the paper's case dichotomy at one node). -/
+theorem hnode_inj_or_collision {x y X Y : Hash}
+    (h : hnode x y = hnode X Y) :
+    (x = X ∧ y = Y) ∨ HasCollision := by
+  by_cases hpre :
+      (0x01 : UInt8) :: (x.val ++ y.val) = 0x01 :: (X.val ++ Y.val)
+  · exact Or.inl (hnode_preimage_inj hpre)
+  · exact Or.inr ⟨_, _, hpre, h⟩
+
+/-- Likewise at a leaf: equal leaf hashes with distinct data collide. -/
+theorem hleaf_inj_or_collision {d e : Bytes}
+    (h : hleaf d = hleaf e) : d = e ∨ HasCollision := by
+  by_cases hde : d = e
+  · exact Or.inl hde
+  · refine Or.inr ⟨0x00 :: d, 0x00 :: e, ?_, h⟩
+    intro hc; injection hc with _ ht; exact hde ht
+
+/-- A non-empty list is its `dropLast` plus its last element
+    (self-contained; no stdlib-name dependence). -/
+theorem eq_dropLast_append_of_getLast? (l : List Hash) (s : Hash)
+    (h : l.getLast? = some s) : l = l.dropLast ++ [s] := by
+  induction l with
+  | nil => simp at h
+  | cons a t ih =>
+      cases t with
+      | nil =>
+          simp at h
+          subst h
+          rfl
+      | cons b u =>
+          have hh : (b :: u).getLast? = some s := by
+            simpa using h
+          have := ih hh
+          calc a :: b :: u = a :: (b :: u) := rfl
+            _ = a :: ((b :: u).dropLast ++ [s]) := by rw [← this]
+            _ = (a :: b :: u).dropLast ++ [s] := by simp
+
+/-- **Root binding** (the Path instance of the paper's Lemma 2): if any
+    reconstruction from `(v, P)` hits the honest root, then either
+    `(v, P)` IS the honest receipt — leaf hash and every consumed
+    sibling — or a collision is exhibited. -/
+theorem root_binding (m : Nat) (D : List Bytes) :
+    ∀ (v : Hash) (P : List Hash), m < D.length →
+    Root v m D.length P = some (MTH D) →
+    (v = hleaf (D.getD m []) ∧ P = Path m D) ∨ HasCollision := by
+  induction m, D using Path.induct with
+  | case1 m D hle =>
+      intro v P hm h
+      have h1 : D.length = 1 := by omega
+      obtain ⟨d, rfl⟩ := exists_singleton_of_length_one D h1
+      have hm0 : m = 0 := by simpa using hm
+      subst hm0
+      have hlen : ([d] : List Bytes).length = 1 := rfl
+      rw [hlen] at h
+      cases P with
+      | nil =>
+          rw [Root_one, MTH_single] at h
+          simp only [Option.some.injEq] at h
+          left
+          refine ⟨?_, by rw [Path]; simp⟩
+          have hg : ([d] : List Bytes).getD 0 [] = d := rfl
+          rw [hg]; exact h
+      | cons p q =>
+          rw [Root_one_cons] at h
+          simp at h
+  | case2 m D hgt k hmk ih =>
+      intro v P hm h
+      have h2 : 2 ≤ D.length := by omega
+      have hkeq : k = kbelow D.length := rfl
+      have hkl : k < D.length := by rw [hkeq]; exact kbelow_lt D.length h2
+      have hmk' : m < kbelow D.length := by rw [← hkeq]; exact hmk
+      have htklen : (D.take k).length = k := by
+        simp [List.length_take]; omega
+      cases hP : P.getLast? with
+      | none =>
+          have hPnil : P = [] := by
+            cases P with
+            | nil => rfl
+            | cons a t => simp at hP
+          subst hPnil
+          rw [Root] at h
+          have hn1 : ¬ D.length = 1 := by omega
+          have hn0 : ¬ D.length = 0 := by omega
+          simp [hn1, hn0] at h
+      | some s =>
+          obtain hsplit := eq_dropLast_append_of_getLast? P s hP
+          rw [hsplit] at h
+          rw [Root_left _ _ _ _ _ h2 hmk', ← hkeq] at h
+          cases hR : Root v m k P.dropLast with
+          | none => rw [hR] at h; simp at h
+          | some x =>
+              rw [hR] at h
+              simp only [Option.map_some, Option.some.injEq] at h
+              rw [MTH_split D h2, ← hkeq] at h
+              rcases hnode_inj_or_collision h with ⟨hx, hs⟩ | hc
+              · have ihm : m < (D.take k).length := by omega
+                have hR' : Root v m (D.take k).length P.dropLast
+                    = some (MTH (D.take k)) := by rw [htklen, hR, hx]
+                rcases ih v P.dropLast ihm hR' with ⟨hv, hPd⟩ | hc
+                · left
+                  refine ⟨?_, ?_⟩
+                  · rw [hv]; exact congrArg hleaf (getD_take D k m hmk)
+                  · have hRHS : Path m D = Path m (D.take k) ++ [MTH (D.drop k)] := by
+                      rw [Path]; simp only [if_neg hgt, ← hkeq, if_pos hmk]
+                    rw [hRHS, hsplit, hPd, hs]
+                · exact Or.inr hc
+              · exact Or.inr hc
+  | case3 m D hgt k hmk ih =>
+      intro v P hm h
+      have h2 : 2 ≤ D.length := by omega
+      have hkeq : k = kbelow D.length := rfl
+      have hkl : k < D.length := by rw [hkeq]; exact kbelow_lt D.length h2
+      have hkp : 0 < k := by rw [hkeq]; exact kbelow_pos D.length
+      have hmk' : ¬ m < kbelow D.length := by rw [← hkeq]; exact hmk
+      have hdplen : (D.drop k).length = D.length - k := by
+        simp [List.length_drop]
+      cases hP : P.getLast? with
+      | none =>
+          have hPnil : P = [] := by
+            cases P with
+            | nil => rfl
+            | cons a t => simp at hP
+          subst hPnil
+          rw [Root] at h
+          have hn1 : ¬ D.length = 1 := by omega
+          have hn0 : ¬ D.length = 0 := by omega
+          simp [hn1, hn0] at h
+      | some s =>
+          obtain hsplit := eq_dropLast_append_of_getLast? P s hP
+          rw [hsplit] at h
+          rw [Root_right _ _ _ _ _ h2 hmk', ← hkeq] at h
+          cases hR : Root v (m - k) (D.length - k) P.dropLast with
+          | none => rw [hR] at h; simp at h
+          | some x =>
+              rw [hR] at h
+              simp only [Option.map_some, Option.some.injEq] at h
+              rw [MTH_split D h2, ← hkeq] at h
+              rcases hnode_inj_or_collision h with ⟨hs, hx⟩ | hc
+              · have ihm : m - k < (D.drop k).length := by omega
+                have hR' : Root v (m - k) (D.drop k).length P.dropLast
+                    = some (MTH (D.drop k)) := by rw [hdplen, hR, hx]
+                rcases ih v P.dropLast ihm hR' with ⟨hv, hPd⟩ | hc
+                · left
+                  have hidx : k + (m - k) = m := by omega
+                  refine ⟨?_, ?_⟩
+                  · rw [hv]
+                    have hh : (D.drop k).getD (m - k) [] = D.getD m [] := by
+                      rw [getD_drop, hidx]
+                    exact congrArg hleaf hh
+                  · have hRHS : Path m D = Path (m - k) (D.drop k) ++ [MTH (D.take k)] := by
+                      rw [Path]; simp only [if_neg hgt, ← hkeq, if_neg hmk]
+                    rw [hRHS, hsplit, hPd, hs]
+                · exact Or.inr hc
+              · exact Or.inr hc
+
+/-- **Theorem 2 (Inclusion soundness: position binding)**, paper §6,
+    constructive form: an accepting receipt whose leaf differs from the
+    honest leaf at position `m` exhibits a SHA-256 collision. -/
+theorem incl_sound (m : Nat) (D : List Bytes) (hm : m < D.length)
+    (d : Bytes) (P : List Hash)
+    (h : Root (hleaf d) m D.length P = some (MTH D)) :
+    d = D.getD m [] ∨ HasCollision := by
+  rcases root_binding m D (hleaf d) P hm h with ⟨hv, _⟩ | hc
+  · exact hleaf_inj_or_collision hv
+  · exact Or.inr hc
+
+end LTLAcc

verification/Proofs/Completeness.lean

@@ -10,7 +10,7 @@ namespace LTLAcc
 
 /-- `Path` (paper §5.3): the operator's inclusion path for index `m`.
     Sibling subtree heads, leaf-to-root order (the paper's `‖ [s]`). -/
-noncomputable def Path (m : Nat) (D : List Bytes) : List Bytes :=
+noncomputable def Path (m : Nat) (D : List Bytes) : List Hash :=
   if D.length ≤ 1 then []
   else
     let k := kbelow D.length
@@ -76,39 +76,37 @@ theorem MTH_split (D : List Bytes) (h : 2 ≤ D.length) :
   have h1 : ¬ D.length = 1 := by omega
   simp only [h0, h1, dite_false]
 
-theorem Root_one (v : Bytes) (m : Nat) : Root v m 1 [] = some v := by
-  rw [Root]; rfl
+theorem Root_one (v : Hash) (m : Nat) : Root v m 1 [] = some v := by
+  rw [Root]; simp
+
+theorem Root_one_cons (v : Hash) (m : Nat) (p : Hash) (q : List Hash) :
+    Root v m 1 (p :: q) = none := by
+  rw [Root]; simp
 
 /-- `Root` at a composite size, left branch (`m < k`). -/
-theorem Root_left (v : Bytes) (m n : Nat) (P : List Bytes) (s : Bytes)
+theorem Root_left (v : Hash) (m n : Nat) (P : List Hash) (s : Hash)
     (hn : 2 ≤ n) (hm : m < kbelow n) :
     Root v m n (P ++ [s]) = (Root v m (kbelow n) P).map (hnode · s) := by
   have h1 : ¬ n = 1 := by omega
   have h0 : ¬ n = 0 := by omega
-  have hne : ¬ (P ++ [s] = []) := by simp
   cases hR : Root v m (kbelow n) P with
   | none =>
       rw [Root]; simp [h0, h1, hm, hR]
-      exact fun hh => absurd hh hne
   | some x =>
       rw [Root]; simp [h0, h1, hm, hR]
-      exact fun hh => absurd hh hne
 
 /-- `Root` at a composite size, right branch (`m ≥ k`). -/
-theorem Root_right (v : Bytes) (m n : Nat) (P : List Bytes) (s : Bytes)
+theorem Root_right (v : Hash) (m n : Nat) (P : List Hash) (s : Hash)
     (hn : 2 ≤ n) (hm : ¬ m < kbelow n) :
     Root v m n (P ++ [s]) =
       (Root v (m - kbelow n) (n - kbelow n) P).map (hnode s ·) := by
   have h1 : ¬ n = 1 := by omega
   have h0 : ¬ n = 0 := by omega
-  have hne : ¬ (P ++ [s] = []) := by simp
   cases hR : Root v (m - kbelow n) (n - kbelow n) P with
   | none =>
       rw [Root]; simp [h0, h1, hm, hR]
-      exact fun hh => absurd hh hne
   | some x =>
       rw [Root]; simp [h0, h1, hm, hR]
-      exact fun hh => absurd hh hne
 
 /-! ### Theorem 1 -/
 

verification/check.sh

@@ -17,7 +17,7 @@ export LEAN_MEM_MB="${LEAN_MEM_MB:-4096}"
 CORES="${LEAN_MAX_CORES:-0-3}"
 
 GEN_MODULES=( LTLAcc/HashExternal )
-PROOFS=( Basic Completeness )
+PROOFS=( Basic Completeness Binding )
 
 # Certificates and their exact expected cones (observed at first green
 # compile, 2026-07-10; any drift in EITHER direction is a failure).
@@ -32,6 +32,11 @@ declare -A CONES=(
   [LTLAcc.ConsRec]="propext, LTLAcc.sha256, Quot.sound"
   [LTLAcc.Path]="propext, LTLAcc.sha256, Quot.sound"
   [LTLAcc.incl_complete]="propext, Classical.choice, LTLAcc.sha256, Quot.sound"
+  [LTLAcc.hnode_preimage_inj]="propext"
+  [LTLAcc.hnode_inj_or_collision]="propext, LTLAcc.sha256"
+  [LTLAcc.hleaf_inj_or_collision]="LTLAcc.sha256"
+  [LTLAcc.root_binding]="propext, Classical.choice, LTLAcc.sha256, Quot.sound"
+  [LTLAcc.incl_sound]="propext, Classical.choice, LTLAcc.sha256, Quot.sound"
 )
 
 free -m | awk '/Mem:/{if($7<2048){print "FATAL: <2GB RAM available — refusing to compile"; exit 1}}'

verification/gen/LTLAcc/HashExternal.lean

@@ -1,12 +1,22 @@
 /- The single sanctioned axiom site of this corpus (mirrors the role of
-   gen/ in the *-ed25519-verified repos): SHA-256 as an opaque function.
-   No properties are assumed of it — in particular NOT collision
-   resistance. The soundness theorems downstream are constructive: they
-   EXHIBIT two distinct preimages with equal image. Believing such a
-   pair cannot be found is the reader's interpretation step, exactly as
-   documented in the paper (§6, Remark 1). -/
+   gen/ in the *-ed25519-verified repos): SHA-256 as an opaque function
+   into 32-byte outputs. No properties are assumed of it — in particular
+   NOT collision resistance; the soundness theorems downstream are
+   constructive, they EXHIBIT two distinct preimages with equal image.
+
+   The fixed output WIDTH is part of the function's type, not an
+   assumption about its behavior: it is what makes hnode argument pairs
+   recoverable from preimages (the paper's "65-byte preimages"
+   parenthetical, made explicit). -/
 namespace LTLAcc
 
-axiom sha256 : List UInt8 → List UInt8
+/-- A 32-byte hash value. -/
+def Hash : Type := { l : List UInt8 // l.length = 32 }
+
+instance : Inhabited Hash := ⟨⟨List.replicate 32 0, by simp⟩⟩
+instance : DecidableEq Hash := fun a b =>
+  decidable_of_iff (a.val = b.val) Subtype.ext_iff.symm
+
+axiom sha256 : List UInt8 → Hash
 
 end LTLAcc