diff --git a/README.md b/README.md index 366d7f0..84e2363 100644 --- a/README.md +++ b/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) diff --git a/verification/Proofs/AxiomCheck.lean b/verification/Proofs/AxiomCheck.lean index fcb364e..8c12f5e 100644 --- a/verification/Proofs/AxiomCheck.lean +++ b/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 diff --git a/verification/Proofs/AxiomCheck.olean b/verification/Proofs/AxiomCheck.olean index beb1113..4e32568 100644 Binary files a/verification/Proofs/AxiomCheck.olean and b/verification/Proofs/AxiomCheck.olean differ diff --git a/verification/Proofs/Descent.lean b/verification/Proofs/Descent.lean new file mode 100644 index 0000000..a3f688f --- /dev/null +++ b/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 \ No newline at end of file diff --git a/verification/Proofs/Descent.olean b/verification/Proofs/Descent.olean new file mode 100644 index 0000000..b44eaef Binary files /dev/null and b/verification/Proofs/Descent.olean differ diff --git a/verification/check.sh b/verification/check.sh index 30eda8d..2616687 100755 --- a/verification/check.sh +++ b/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}}'