S4: descent extractor extractMTH (Theorem 3 step 3 + F2 restoration), non-vacuous

The 'descend' step of the paper's Theorem 3, built extractor-first per
the S3.5 lesson (never a bare '∨ collision'):

- extractMTH (D D'): total function that, given two equal-length leaf
  lists sharing a Merkle root, walks the common-shape tree to the first
  divergence and returns the concrete colliding preimage pair (a node
  pair, or a leaf pair at the bottom).
- extractMTH_correct: |D|=|D'| ∧ D≠D' ∧ MTH D = MTH D' →
  IsCollision (extractMTH D D'). Proven by functional induction on
  extractMTH; composite case uses MTH_split + append_inj (fixed-width
  Hash) to split node preimages or exhibit the node collision.
- extractMTH_nonvacuous: equal lists → output NOT a collision (pinned),
  so the conclusion is false for some inputs ⇒ choice-proof.

This also RESTORES, in explicit non-vacuous form, the receipt-uniqueness
content of Lemma 2 deleted in the S3.5 cleanup (re-audit F2): the honest
Merkle fold is injective up to a collision.

18 certs green. Fable statement-audit passed (matches paper Thm 3 step 3
verbatim). LTL untouched (12 leaves, bcd15f9d).

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

README.md

@@ -13,7 +13,9 @@ the same discipline as the four `*-ed25519-verified` subject corpora.
 | 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 binding content (Lemma 2) | **inlined in the extractor walk** (extractIncl); standalone receipt-uniqueness theorem queued for S4 restoration in extractor form |
-| L5 | inclusion soundness = EXPLICIT collision extractor extractIncl+correctness (Theorem 2) **done, non-vacuous**; consistency (Theorem 3) pending |
+| L5 | inclusion soundness = EXPLICIT extractor `extractIncl` (Theorem 2) **done, non-vacuous** |
+| L6a | descent extractor `extractMTH` (Theorem 3 step 3; restored receipt-uniqueness of Lemma 2) **done, non-vacuous** |
+| L6b | ConsRec binding + Theorem 3 assembly (extractCons) | pending (S5) |
 | L6 | pin-store state machine safety (Proposition 1) | pending |
 
 ## Discipline (identical to the subject corpora)

verification/Proofs/AxiomCheck.lean

@@ -2,6 +2,7 @@
 import Proofs.Basic
 import Proofs.Completeness
 import Proofs.Extract
+import Proofs.Descent
 #print axioms LTLAcc.domsep
 #print axioms LTLAcc.kbelow_pos
 #print axioms LTLAcc.kbelow_lt
@@ -17,3 +18,6 @@ import Proofs.Extract
 #print axioms LTLAcc.extractIncl
 #print axioms LTLAcc.extractIncl_correct
 #print axioms LTLAcc.extractIncl_nonvacuous
+#print axioms LTLAcc.extractMTH
+#print axioms LTLAcc.extractMTH_correct
+#print axioms LTLAcc.extractMTH_nonvacuous

verification/Proofs/Descent.lean

@@ -0,0 +1,126 @@
+/- S4 — the DESCENT extractor: two equal-length leaf lists with the same
+   Merkle root yield an explicit SHA-256 collision.
+
+   This is step 3 of the paper's Theorem 3 ("descend"), and it also
+   restores — in explicit, non-vacuous form — the receipt-uniqueness
+   content that the S3.5 cleanup deleted with `root_binding` (re-audit
+   F2): the honest fold is injective up to a collision. Built as a named
+   function `extractMTH` with a correctness statement about ITS OUTPUT,
+   so pigeonhole/choice cannot discharge it (guarded by
+   `extractMTH_nonvacuous`). -/
+import Proofs.Extract
+
+namespace LTLAcc
+
+/-- The descent extractor. Given two leaf lists of equal length with
+    equal Merkle roots but differing data, walk the (shared-shape) tree
+    to the first divergence and return the concrete colliding preimage
+    pair — a node preimage pair, or a leaf preimage pair at the bottom. -/
+noncomputable def extractMTH (D D' : List Bytes) : List UInt8 × List UInt8 :=
+  if D.length ≤ 1 then
+    (0x00 :: D.headD [], 0x00 :: D'.headD [])
+  else
+    let k := kbelow D.length
+    if MTH (D.take k) = MTH (D'.take k) ∧ MTH (D.drop k) = MTH (D'.drop k) then
+      if D.take k ≠ D'.take k then extractMTH (D.take k) (D'.take k)
+      else extractMTH (D.drop k) (D'.drop k)
+    else
+      (0x01 :: ((MTH (D.take k)).val ++ (MTH (D.drop k)).val),
+       0x01 :: ((MTH (D'.take k)).val ++ (MTH (D'.drop k)).val))
+termination_by D.length
+decreasing_by
+  · simp only [List.length_take]
+    have h2 : 2 ≤ D.length := by omega
+    have hk := kbelow_lt D.length h2
+    omega
+  · simp only [List.length_drop]
+    have hp := kbelow_pos D.length
+    omega
+
+/-- Take/drop reconstruct the whole list (self-contained). -/
+theorem take_append_drop (l : List Bytes) (k : Nat) :
+    l.take k ++ l.drop k = l := List.take_append_drop k l
+
+/-- **Descent correctness** (paper Theorem 3, step 3; and the restored
+    receipt-uniqueness content of Lemma 2 in explicit form): for equal-
+    length lists with equal roots but differing data, `extractMTH`
+    outputs a genuine SHA-256 collision. -/
+theorem extractMTH_correct (D D' : List Bytes) :
+    D.length = D'.length → D ≠ D' → MTH D = MTH D' →
+    IsCollision (extractMTH D D').1 (extractMTH D D').2 := by
+  induction D, D' using extractMTH.induct with
+  | case1 D D' hle =>
+      intro hlen hne hroot
+      rw [extractMTH]; simp only [hle, if_pos]
+      have hd1 : D.length = 1 := by
+        rcases Nat.eq_zero_or_pos D.length with h0 | hp
+        · exfalso; apply hne
+          have hD : D = [] := List.length_eq_zero_iff.mp h0
+          have hD' : D' = [] := List.length_eq_zero_iff.mp (by omega)
+          rw [hD, hD']
+        · omega
+      obtain ⟨a, rfl⟩ := exists_singleton_of_length_one D hd1
+      obtain ⟨b, rfl⟩ := exists_singleton_of_length_one D' (by omega)
+      have hab : a ≠ b := by intro h; exact hne (by rw [h])
+      rw [MTH_single, MTH_single] at hroot
+      refine ⟨?_, ?_⟩
+      · intro hc; injection hc with _ ht; exact hab ht
+      · simpa using hroot
+  | case2 D D' hgt k hhalves htake ih =>
+      intro hlen hne hroot
+      have hk : kbelow D.length = k := rfl
+      rw [extractMTH, if_neg hgt, hk, if_pos hhalves, if_pos htake]
+      apply ih
+      · simp only [List.length_take]; omega
+      · exact htake
+      · exact hhalves.1
+  | case3 D D' hgt k hhalves htake ih =>
+      intro hlen hne hroot
+      have hk : kbelow D.length = k := rfl
+      rw [extractMTH, if_neg hgt, hk, if_pos hhalves, if_neg htake]
+      apply ih
+      · simp only [List.length_drop]; omega
+      · intro hdrop
+        apply hne
+        have ht : D.take k = D'.take k := Decidable.of_not_not htake
+        calc D = D.take k ++ D.drop k := (take_append_drop D k).symm
+          _ = D'.take k ++ D'.drop k := by rw [ht, hdrop]
+          _ = D' := take_append_drop D' k
+      · exact hhalves.2
+  | case4 D D' hgt k hhalves =>
+      intro hlen hne hroot
+      have h2 : 2 ≤ D.length := by omega
+      have h2' : 2 ≤ D'.length := by omega
+      have hkeq : kbelow D'.length = k := by rw [← hlen]
+      have hk : kbelow D.length = k := rfl
+      rw [extractMTH, if_neg hgt, hk, if_neg hhalves]
+      have hsD : MTH D = hnode (MTH (D.take k)) (MTH (D.drop k)) := MTH_split D h2
+      have hsD' : MTH D' = hnode (MTH (D'.take k)) (MTH (D'.drop k)) := by
+        have := MTH_split D' h2'; rw [hkeq] at this; exact this
+      refine ⟨?_, ?_⟩
+      · intro hc
+        injection hc with _ happ
+        have hln : (MTH (D.take k)).val.length = (MTH (D'.take k)).val.length := by
+          rw [(MTH (D.take k)).property, (MTH (D'.take k)).property]
+        obtain ⟨e1, e2⟩ := List.append_inj happ hln
+        exact hhalves ⟨Subtype.ext e1, Subtype.ext e2⟩
+      · show sha256 _ = sha256 _
+        have e1 : sha256 (0x01 :: ((MTH (D.take k)).val ++ (MTH (D.drop k)).val)) = MTH D :=
+          hsD.symm
+        have e2 : sha256 (0x01 :: ((MTH (D'.take k)).val ++ (MTH (D'.drop k)).val)) = MTH D' :=
+          hsD'.symm
+        rw [e1, e2]; exact hroot
+
+/-- Permanent non-vacuity witness (re-audit discipline): on EQUAL lists
+    the extractor's output is not a collision (both sides identical), so
+    `extractMTH_correct`'s conclusion is false for some inputs and cannot
+    be discharged by pigeonhole/choice. -/
+theorem extractMTH_nonvacuous :
+    ¬ IsCollision (extractMTH [([7] : List UInt8)] [([7] : List UInt8)]).1
+                  (extractMTH [([7] : List UInt8)] [([7] : List UInt8)]).2 := by
+  rw [extractMTH]
+  simp only [List.length_singleton, if_pos (by omega : (1:Nat) ≤ 1)]
+  intro hcol
+  exact hcol.1 rfl
+
+end LTLAcc

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 Extract )
+PROOFS=( Basic Completeness Extract Descent )
 
 # Certificates and their exact expected cones (observed at first green
 # compile, 2026-07-10; any drift in EITHER direction is a failure).
@@ -37,6 +37,9 @@ declare -A CONES=(
   [LTLAcc.extractIncl]="propext, LTLAcc.sha256, Quot.sound"
   [LTLAcc.extractIncl_correct]="propext, Classical.choice, LTLAcc.sha256, Quot.sound"
   [LTLAcc.extractIncl_nonvacuous]="propext, LTLAcc.sha256, Quot.sound"
+  [LTLAcc.extractMTH]="propext, LTLAcc.sha256, Quot.sound"
+  [LTLAcc.extractMTH_correct]="propext, Classical.choice, LTLAcc.sha256, Quot.sound"
+  [LTLAcc.extractMTH_nonvacuous]="propext, LTLAcc.sha256, Quot.sound"
 )
 
 free -m | awk '/Mem:/{if($7<2048){print "FATAL: <2GB RAM available — refusing to compile"; exit 1}}'