mirror of
https://github.com/saymrwulf/ltl-accumulator-verified.git
synced 2026-09-10 21:00:57 +00:00
S3.5: explicit collision extractor — Theorem 2 made non-vacuous, vacuous forms removed
The S3 Socratic re-audit found incl_sound was kernel-perfect but VACUOUS:
its '... ∨ HasCollision' disjunct (∃ x y, x≠y ∧ sha256 x = sha256 y) is
provable by pigeonhole ALONE (sha256: infinite List UInt8 → finite
32-byte Hash), so the theorem said nothing about forgeries. Even a
data-carrying {p // IsCollision p} disjunct fails (Classical.choice
inhabits it). The only faithful rendering of the paper's 'explicit
algorithm 𝓔' is a NAMED FUNCTION whose correctness is a claim about ITS
OUTPUT.
- extractIncl (m D d P): total function that walks the honest tree and
returns the concrete colliding preimage pair at the first divergence
(a node preimage pair, or the leaf preimage pair at the bottom).
- extractIncl_correct: d ≠ D[m] ∧ accepting-receipt →
IsCollision (extractIncl …).1 (extractIncl …).2. A statement ABOUT the
fixed function's output; pigeonhole cannot discharge it.
ADVERSARIAL CHECK (probe, since removed): proved
¬ IsCollision (extractIncl 0 [[7]] [7] []) — i.e. on a NON-forgery input
the output is provably NOT a collision, so the conclusion is genuinely
false for some inputs ⇒ non-vacuous, choice-proof.
- Removed the vacuous theorems entirely (incl_sound, root_binding,
hnode/hleaf_inj_or_collision, HasCollision def) so no hollow statement
survives in a corpus destined for the log. Kept the real building
blocks (hnode_preimage_inj [propext]; eq_dropLast helper moved to
Completeness; Binding.lean deleted).
extractIncl_correct cone [propext, Classical.choice, LTLAcc.sha256,
Quot.sound]. THE button green (14 certs). Fable statement-audit passed.
LTL untouched (12 leaves, bcd15f9d).
Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
This commit is contained in:
parent
eb3df7503f
commit
e270872a27
10 changed files with 226 additions and 196 deletions
|
|
@ -13,7 +13,7 @@ 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 | 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 |
|
||||
| L5 | inclusion soundness = EXPLICIT collision extractor extractIncl+correctness (Theorem 2) **done, non-vacuous**; consistency (Theorem 3) pending |
|
||||
| L6 | pin-store state machine safety (Proposition 1) | pending |
|
||||
|
||||
## Discipline (identical to the subject corpora)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
/- Axiom-cone observation for the audit (Phase 3 of check.sh). -/
|
||||
import Proofs.Basic
|
||||
import Proofs.Completeness
|
||||
import Proofs.Binding
|
||||
import Proofs.Extract
|
||||
#print axioms LTLAcc.domsep
|
||||
#print axioms LTLAcc.kbelow_pos
|
||||
#print axioms LTLAcc.kbelow_lt
|
||||
|
|
@ -13,7 +13,6 @@ import Proofs.Binding
|
|||
#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
|
||||
#print axioms LTLAcc.IsCollision
|
||||
#print axioms LTLAcc.extractIncl
|
||||
#print axioms LTLAcc.extractIncl_correct
|
||||
|
|
|
|||
Binary file not shown.
|
|
@ -1,185 +0,0 @@
|
|||
/- 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
|
||||
|
|
@ -161,4 +161,24 @@ theorem incl_complete (m : Nat) (D : List Bytes) (hm : m < D.length) :
|
|||
rw [hrec, MTH_split D h2, ← hkeq]
|
||||
rfl
|
||||
|
||||
/-- 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
|
||||
|
||||
end LTLAcc
|
||||
|
|
|
|||
Binary file not shown.
197
verification/Proofs/Extract.lean
Normal file
197
verification/Proofs/Extract.lean
Normal file
|
|
@ -0,0 +1,197 @@
|
|||
/- S3.5 — the EXPLICIT collision extractor for inclusion soundness.
|
||||
|
||||
Why a function and not `∃`: `Hash` is a finite type (32-byte lists),
|
||||
`sha256` has an infinite domain, so `∃ x y, x ≠ y ∧ sha256 x = sha256 y`
|
||||
is provable by pigeonhole ALONE — a bare-existential soundness theorem
|
||||
is vacuous, and even a data-carrying `{p // IsCollision p}` disjunct is
|
||||
inhabited by `Classical.choice`. The paper's Theorem 2 is an *explicit
|
||||
algorithm* 𝓔; faithfulness demands a named function `extractIncl` and a
|
||||
correctness statement ABOUT ITS OUTPUT — a claim pigeonhole cannot
|
||||
discharge, because it pins down *which* pair. -/
|
||||
import Proofs.Completeness
|
||||
|
||||
namespace LTLAcc
|
||||
|
||||
/-- A specific colliding pair (predicate on concrete byte strings). -/
|
||||
def IsCollision (x y : List UInt8) : Prop :=
|
||||
x ≠ y ∧ sha256 x = sha256 y
|
||||
|
||||
/-- The extractor 𝓔 for inclusion (paper Theorem 2). Given the honest
|
||||
leaf list `D`, a claimed index `m`, a claimed leaf `d`, and a path
|
||||
`P`, it walks the honest tree and returns the concrete preimage pair
|
||||
at the first level where the offered reconstruction diverges from the
|
||||
honest tree — a node preimage pair high up, or the leaf preimage pair
|
||||
at the bottom. Total (junk defaults on the branches the soundness
|
||||
hypothesis excludes). -/
|
||||
noncomputable def extractIncl (m : Nat) (D : List Bytes) (d : Bytes)
|
||||
(P : List Hash) : List UInt8 × List UInt8 :=
|
||||
if D.length ≤ 1 then
|
||||
-- leaf level: the offered leaf `d` vs the honest leaf `D[m]`
|
||||
(0x00 :: d, 0x00 :: D.getD m [])
|
||||
else
|
||||
let k := kbelow D.length
|
||||
match P.getLast? with
|
||||
| none => ([], []) -- excluded: composite size needs a sibling
|
||||
| some s =>
|
||||
if m < k then
|
||||
let child := (Root (hleaf d) m k P.dropLast).getD default
|
||||
if child = MTH (D.take k) ∧ s = MTH (D.drop k) then
|
||||
extractIncl m (D.take k) d P.dropLast
|
||||
else
|
||||
(0x01 :: (child.val ++ s.val),
|
||||
0x01 :: ((MTH (D.take k)).val ++ (MTH (D.drop k)).val))
|
||||
else
|
||||
let child := (Root (hleaf d) (m - k) (D.length - k) P.dropLast).getD default
|
||||
if s = MTH (D.take k) ∧ child = MTH (D.drop k) then
|
||||
extractIncl (m - k) (D.drop k) d P.dropLast
|
||||
else
|
||||
(0x01 :: (s.val ++ child.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
|
||||
|
||||
/-- **Theorem 2 (Inclusion soundness), explicit form** — the faithful
|
||||
replacement for the vacuous bare-existential version. If an accepting
|
||||
receipt opens position `m` to a leaf `d` different from the honest
|
||||
`D[m]`, then `extractIncl` OUTPUTS a genuine SHA-256 collision. The
|
||||
statement is about the fixed function's output, so pigeonhole cannot
|
||||
prove it: it must exhibit that THIS pair collides. -/
|
||||
theorem extractIncl_correct (m : Nat) (D : List Bytes) :
|
||||
∀ (d : Bytes) (P : List Hash), m < D.length → d ≠ D.getD m [] →
|
||||
Root (hleaf d) m D.length P = some (MTH D) →
|
||||
IsCollision (extractIncl m D d P).1 (extractIncl m D d P).2 := by
|
||||
induction m, D using Path.induct with
|
||||
| case1 m D hle =>
|
||||
intro d P hm hd h
|
||||
have h1 : D.length = 1 := by omega
|
||||
obtain ⟨e, rfl⟩ := exists_singleton_of_length_one D h1
|
||||
have hm0 : m = 0 := by simpa using hm
|
||||
subst hm0
|
||||
rw [extractIncl]
|
||||
simp only [List.length_singleton, if_pos (by omega : (1:Nat) ≤ 1)]
|
||||
have hlen : ([e] : 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
|
||||
have hde : d ≠ e := by simpa using hd
|
||||
refine ⟨?_, ?_⟩
|
||||
· intro hc; injection hc with _ ht; exact hde ht
|
||||
· have hg : ([e] : List Bytes).getD 0 [] = e := rfl
|
||||
rw [hg]; exact h
|
||||
| cons p q =>
|
||||
rw [Root_one_cons] at h
|
||||
exact absurd h (by simp)
|
||||
| case2 m D hgt k hmk ih =>
|
||||
intro d P hm hd 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
|
||||
have hh := h
|
||||
rw [hsplit, Root_left _ _ _ _ _ h2 hmk', ← hkeq] at hh
|
||||
cases hR : Root (hleaf d) m k P.dropLast with
|
||||
| none => rw [hR] at hh; simp at hh
|
||||
| some x =>
|
||||
rw [hR] at hh
|
||||
simp only [Option.map_some, Option.some.injEq] at hh
|
||||
rw [MTH_split D h2, ← hkeq] at hh
|
||||
rw [extractIncl]
|
||||
simp only [if_neg hgt, hP, ← hkeq, if_pos hmk]
|
||||
have hchild : (Root (hleaf d) m k P.dropLast).getD default = x := by
|
||||
rw [hR]; rfl
|
||||
rw [hchild]
|
||||
by_cases hpair : x = MTH (D.take k) ∧ s = MTH (D.drop k)
|
||||
· simp only [if_pos hpair]
|
||||
have ihm : m < (D.take k).length := by omega
|
||||
have hgetd : (D.take k).getD m [] = D.getD m [] := getD_take D k m hmk
|
||||
have hd' : d ≠ (D.take k).getD m [] := by rw [hgetd]; exact hd
|
||||
have hrec : Root (hleaf d) m (D.take k).length P.dropLast
|
||||
= some (MTH (D.take k)) := by rw [htklen, hR, hpair.1]
|
||||
exact ih d P.dropLast ihm hd' hrec
|
||||
· simp only [if_neg hpair]
|
||||
refine ⟨?_, ?_⟩
|
||||
· intro hc
|
||||
injection hc with _ happ
|
||||
have hlen : x.val.length = (MTH (D.take k)).val.length := by
|
||||
rw [x.property, (MTH (D.take k)).property]
|
||||
obtain ⟨hx, hs⟩ := List.append_inj happ hlen
|
||||
exact hpair ⟨Subtype.ext hx, Subtype.ext hs⟩
|
||||
· exact hh
|
||||
| case3 m D hgt k hmk ih =>
|
||||
intro d P hm hd 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
|
||||
have hh := h
|
||||
rw [hsplit, Root_right _ _ _ _ _ h2 hmk', ← hkeq] at hh
|
||||
cases hR : Root (hleaf d) (m - k) (D.length - k) P.dropLast with
|
||||
| none => rw [hR] at hh; simp at hh
|
||||
| some x =>
|
||||
rw [hR] at hh
|
||||
simp only [Option.map_some, Option.some.injEq] at hh
|
||||
rw [MTH_split D h2, ← hkeq] at hh
|
||||
rw [extractIncl]
|
||||
simp only [if_neg hgt, hP, ← hkeq, if_neg hmk]
|
||||
have hchild : (Root (hleaf d) (m - k) (D.length - k) P.dropLast).getD default = x := by
|
||||
rw [hR]; rfl
|
||||
rw [hchild]
|
||||
by_cases hpair : s = MTH (D.take k) ∧ x = MTH (D.drop k)
|
||||
· simp only [if_pos hpair]
|
||||
have ihm : m - k < (D.drop k).length := by omega
|
||||
have hidx : k + (m - k) = m := by omega
|
||||
have hgetd : (D.drop k).getD (m - k) [] = D.getD m [] := by
|
||||
rw [getD_drop, hidx]
|
||||
have hd' : d ≠ (D.drop k).getD (m - k) [] := by rw [hgetd]; exact hd
|
||||
have hrec : Root (hleaf d) (m - k) (D.drop k).length P.dropLast
|
||||
= some (MTH (D.drop k)) := by rw [hdplen, hR, hpair.2]
|
||||
exact ih d P.dropLast ihm hd' hrec
|
||||
· simp only [if_neg hpair]
|
||||
refine ⟨?_, ?_⟩
|
||||
· intro hc
|
||||
injection hc with _ happ
|
||||
have hlen : s.val.length = (MTH (D.take k)).val.length := by
|
||||
rw [s.property, (MTH (D.take k)).property]
|
||||
obtain ⟨hs, hx⟩ := List.append_inj happ hlen
|
||||
exact hpair ⟨Subtype.ext hs, Subtype.ext hx⟩
|
||||
· exact hh
|
||||
|
||||
end LTLAcc
|
||||
BIN
verification/Proofs/Extract.olean
Normal file
BIN
verification/Proofs/Extract.olean
Normal file
Binary file not shown.
BIN
verification/Proofs/Probe.olean
Normal file
BIN
verification/Proofs/Probe.olean
Normal file
Binary file not shown.
|
|
@ -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 Binding )
|
||||
PROOFS=( Basic Completeness Extract )
|
||||
|
||||
# Certificates and their exact expected cones (observed at first green
|
||||
# compile, 2026-07-10; any drift in EITHER direction is a failure).
|
||||
|
|
@ -33,10 +33,9 @@ declare -A CONES=(
|
|||
[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"
|
||||
[LTLAcc.IsCollision]="LTLAcc.sha256"
|
||||
[LTLAcc.extractIncl]="propext, LTLAcc.sha256, Quot.sound"
|
||||
[LTLAcc.extractIncl_correct]="propext, Classical.choice, LTLAcc.sha256, Quot.sound"
|
||||
)
|
||||
|
||||
free -m | awk '/Mem:/{if($7<2048){print "FATAL: <2GB RAM available — refusing to compile"; exit 1}}'
|
||||
|
|
|
|||
Loading…
Reference in a new issue