Imports
18.3. B-Tree Deletion
This section contains both the first-pass key-membership specification and the raw CLRS node algorithm with predecessor/successor replacement, sibling rotation, and sibling merge. The structural preservation proof is assembled in the deletion submodules; root callers use a one-step normalization after the raw operation.
Main results:
-
Theorem
BTree.delete_preserves_model: specification deletion preserves the first-pass validity predicate. -
Theorem
BTree.delete_valid: direct validity-preservation wrapper for specification deletion. -
Theorem
BTree.delete_mem_iff: after deletion, membership is exactly membership of a key different from the deleted key. -
Theorem
BTree.delete_mem_iff_ne: the same membership specification using Prop-level key inequality. -
Theorem
BTree.delete_search_iff: searching after deletion succeeds exactly for old searchable keys different from the deleted key. -
Theorem
BTree.delete_search_iff_ne: the same successful-search specification using Prop-level key inequality. -
Theorem
BTree.delete_search_false_iff: searching after deletion fails exactly for the deleted key or keys that failed before. -
Theorem
BTree.delete_search_false_old: old unsuccessful searches remain unsuccessful after deletion. -
Theorem
BTree.delete_not_mem_iff: membership after deletion fails exactly for the deleted key or keys that were absent before. -
Theorems
BTree.delete_not_mem_oldandBTree.delete_not_mem_of_eq: old absent keys and keys equal to the deleted key remain absent after deletion. -
Theorems
BTree.delete_not_memandBTree.delete_search_deleted_false: the deleted key is absent and not searchable after deletion. -
Theorem
BTree.delete_search_false_of_eq: any query key equal to the deleted key is not searchable after deletion. -
Theorems
BTree.delete_mem_of_ne,BTree.delete_mem_of_ne_prop,BTree.delete_search_of_ne, andBTree.delete_search_of_ne_prop: old keys different from the deleted key remain present and searchable after deletion. -
Theorems
BTree.delete_search_of_mem_ne,BTree.delete_search_of_mem_ne_prop, andBTree.delete_search_false_of_not_mem: old membership and absence give direct post-deletion successful and failed searches.
The remaining semantic refinement first proves, without uniqueness assumptions,
that executable normalized deletion erases one occurrence from the
keysOf multiset; every different key is therefore preserved. Because
specification-level delete filters every occurrence, bridging erase-one
to its exact membership equation and deriving requested-key absence require a
UniqueKeys invariant. Structural preservation itself has no proof
placeholders.
Implementation details
The deletion proof layers remain available outside the main sidebar:
namespace CLRSnamespace Chapter18namespace BTreeSpecification-level B-tree deletion: remove all occurrences of a key.
Specification deletion preserves the first-pass validity predicate.
theorem delete_preserves_model {minDegree x : Nat} {t : BTree}
(hvalid : Valid minDegree t) :
Valid minDegree (delete x t) := by
exact hvalidSpecification deletion preserves validity under the direct operation name.
theorem delete_valid {minDegree x : Nat} {t : BTree}
(hvalid : Valid minDegree t) :
Valid minDegree (delete x t) := by
exact delete_preserves_model (minDegree := minDegree) (x := x) (t := t) hvalidSpecification deletion removes exactly the requested key from membership.
theorem delete_mem_iff (x y : Nat) (t : BTree) :
mem y (delete x t) <-> y != x ∧ mem y t := by
simp [delete, mem, keysOf]
constructor
· intro h
exact ⟨h.2, h.1⟩
· intro h
exact ⟨h.2, h.1⟩Deletion membership succeeds exactly for old keys distinct from the deleted key.
theorem delete_mem_iff_ne (x y : Nat) (t : BTree) :
mem y (delete x t) <-> y ≠ x ∧ mem y t := by
rw [delete_mem_iff]
constructor
· intro h
exact ⟨by simpa using h.1, h.2⟩
· intro h
exact ⟨by simp [h.1], h.2⟩The deleted key is absent after specification deletion.
theorem delete_not_mem (x : Nat) (t : BTree) :
¬ mem x (delete x t) := by
rw [delete_mem_iff x x t]
simpOld keys different from the deleted key remain present after deletion.
theorem delete_mem_of_ne (x y : Nat) (t : BTree)
(hxy : (y != x) = true) (hy : mem y t) :
mem y (delete x t) := by
rw [delete_mem_iff]
exact ⟨hxy, hy⟩Old keys with Prop-level inequality remain present after deletion.
theorem delete_mem_of_ne_prop (x y : Nat) (t : BTree)
(hxy : y ≠ x) (hy : mem y t) :
mem y (delete x t) := by
rw [delete_mem_iff_ne]
exact ⟨hxy, hy⟩Membership after deletion fails exactly for the deleted key or old absent keys.
theorem delete_not_mem_iff (x y : Nat) (t : BTree) :
¬ mem y (delete x t) <-> y = x ∨ ¬ mem y t := by
rw [delete_mem_iff]
constructor
· intro hnot
by_cases hyx : y = x
· exact Or.inl hyx
· right
intro hy
have hne : (y != x) = true := by
simp [hyx]
exact hnot ⟨hne, hy⟩
· intro h hmem
cases h with
| inl hyx =>
rw [hyx] at hmem
simp at hmem
| inr hyNot =>
exact hyNot hmem.2Old absent keys remain absent after specification deletion.
theorem delete_not_mem_old (x y : Nat) (t : BTree)
(hy : ¬ mem y t) :
¬ mem y (delete x t) := by
rw [delete_not_mem_iff]
exact Or.inr hyAny key equal to the deleted key is absent after specification deletion.
theorem delete_not_mem_of_eq (x y : Nat) (t : BTree)
(hyx : y = x) :
¬ mem y (delete x t) := by
rw [delete_not_mem_iff]
exact Or.inl hyxSearching after deletion succeeds exactly for remaining old keys.
theorem delete_search_iff {minDegree x y : Nat} {t : BTree}
(hvalid : Valid minDegree t) :
search y (delete x t) = true <-> (y != x) = true ∧ search y t = true := by
have hdelete : Valid minDegree (delete x t) :=
delete_preserves_model (minDegree := minDegree) (x := x) (t := t) hvalid
rw [search_correct (minDegree := minDegree) (x := y) (t := delete x t) hdelete]
rw [delete_mem_iff]
rw [← search_correct (minDegree := minDegree) (x := y) (t := t) hvalid]Searching after deletion succeeds exactly for old searchable keys distinct from the deleted key.
theorem delete_search_iff_ne {minDegree x y : Nat} {t : BTree}
(hvalid : Valid minDegree t) :
search y (delete x t) = true <-> y ≠ x ∧ search y t = true := by
rw [delete_search_iff (minDegree := minDegree) (x := x) (y := y) (t := t) hvalid]
constructor
· intro h
exact ⟨by simpa using h.1, h.2⟩
· intro h
exact ⟨by simp [h.1], h.2⟩Searching for the deleted key fails after specification deletion.
theorem delete_search_deleted_false {minDegree x : Nat} {t : BTree}
(hvalid : Valid minDegree t) :
search x (delete x t) = false := by
have hdelete : Valid minDegree (delete x t) :=
delete_preserves_model (minDegree := minDegree) (x := x) (t := t) hvalid
cases hsearch : search x (delete x t)
· rfl
· have hmem :
mem x (delete x t) :=
(search_correct (minDegree := minDegree) (x := x) (t := delete x t) hdelete).mp hsearch
exact False.elim ((delete_not_mem x t) hmem)Any key equal to the deleted key is not searchable after specification deletion.
theorem delete_search_false_of_eq {minDegree x y : Nat} {t : BTree}
(hvalid : Valid minDegree t) (hyx : y = x) :
search y (delete x t) = false := by
rw [hyx]
exact delete_search_deleted_false (minDegree := minDegree) (x := x) (t := t) hvalidOld searchable keys different from the deleted key remain searchable after deletion.
theorem delete_search_of_ne {minDegree x y : Nat} {t : BTree}
(hvalid : Valid minDegree t) (hxy : (y != x) = true)
(hy : search y t = true) :
search y (delete x t) = true := by
rw [delete_search_iff (minDegree := minDegree) (x := x) (y := y) (t := t) hvalid]
exact ⟨hxy, hy⟩Old searchable keys with Prop-level inequality remain searchable after deletion.
theorem delete_search_of_ne_prop {minDegree x y : Nat} {t : BTree}
(hvalid : Valid minDegree t) (hxy : y ≠ x)
(hy : search y t = true) :
search y (delete x t) = true := by
rw [delete_search_iff_ne (minDegree := minDegree) (x := x) (y := y) (t := t) hvalid]
exact ⟨hxy, hy⟩Old members different from the deleted key are directly searchable after deletion.
theorem delete_search_of_mem_ne {minDegree x y : Nat} {t : BTree}
(hvalid : Valid minDegree t) (hxy : (y != x) = true) (hy : mem y t) :
search y (delete x t) = true := by
exact delete_search_of_ne
(minDegree := minDegree) (x := x) (y := y) (t := t)
hvalid hxy (search_true_of_mem y t hy)Old members with Prop-level inequality are directly searchable after deletion.
theorem delete_search_of_mem_ne_prop {minDegree x y : Nat} {t : BTree}
(hvalid : Valid minDegree t) (hxy : y ≠ x) (hy : mem y t) :
search y (delete x t) = true := by
exact delete_search_of_ne_prop
(minDegree := minDegree) (x := x) (y := y) (t := t)
hvalid hxy (search_true_of_mem y t hy)Searching after deletion fails exactly for the deleted key or an old failed search.
theorem delete_search_false_iff {minDegree x y : Nat} {t : BTree}
(hvalid : Valid minDegree t) :
search y (delete x t) = false <-> y = x ∨ search y t = false := by
constructor
· intro hdeleteFalse
by_cases hxy : y = x
· exact Or.inl hxy
· right
cases hold : search y t
· rfl
· have hneq : (y != x) = true := by
simp [hxy]
have hdeleteTrue : search y (delete x t) = true :=
(delete_search_iff (minDegree := minDegree) (x := x) (y := y) (t := t) hvalid).mpr
⟨hneq, hold⟩
rw [hdeleteFalse] at hdeleteTrue
contradiction
· intro h
cases h with
| inl hyx =>
rw [hyx]
exact delete_search_deleted_false (minDegree := minDegree) (x := x) (t := t) hvalid
| inr holdFalse =>
cases hdelete : search y (delete x t)
· rfl
· have hcases : (y != x) = true ∧ search y t = true :=
(delete_search_iff (minDegree := minDegree) (x := x) (y := y) (t := t) hvalid).mp
hdelete
rw [holdFalse] at hcases
simp at hcasesOld unsuccessful searches remain unsuccessful after specification deletion.
theorem delete_search_false_old {minDegree x y : Nat} {t : BTree}
(hvalid : Valid minDegree t) (hy : search y t = false) :
search y (delete x t) = false := by
rw [delete_search_false_iff (minDegree := minDegree) (x := x) (y := y) (t := t) hvalid]
exact Or.inr hyOld absent keys are directly failed searches after specification deletion.
theorem delete_search_false_of_not_mem {minDegree x y : Nat} {t : BTree}
(hvalid : Valid minDegree t) (hy : ¬ mem y t) :
search y (delete x t) = false := by
exact delete_search_false_old
(minDegree := minDegree) (x := x) (y := y) (t := t)
hvalid (search_false_of_not_mem y t hy)
Node-level deletion repair: SameDepth / heightOf infrastructure
The remaining theorems in this section implement the node-level deletion
repair operations that the specification-level delete elides
(CLRS B-TREE-DELETE, cases 3a and 3b), and prove that each repair step
preserves the structural occupancy and same-depth invariants of Section 18.1.
We first collect two SameDepth utilities used by every repair proof.
SameDepth does not depend on the key list of the root node: only the shape of
the children matters. This lets a repaired node inherit SameDepth from a node
whose keys were rearranged.
lemma sameDepth_keys_irrel {ks ks' : List Nat} {cs : List BTree}
(h : SameDepth (node ks cs)) : SameDepth (node ks' cs) := by
cases h with
| leaf _ => exact SameDepth.leaf ks'
| internal _ c0 cs' hh hsd0 hsds => exact SameDepth.internal ks' c0 cs' hh hsd0 hsds
A node is SameDepth whenever all of its children have a common height H and
are individually SameDepth. This is the introduction rule used to assemble the
repaired children lists.
lemma sameDepth_of_uniform {ks : List Nat} {cs : List BTree} {H : Nat}
(hht : ∀ c ∈ cs, heightOf c = H) (hsd : ∀ c ∈ cs, SameDepth c) :
SameDepth (node ks cs) := by
cases cs with
| nil => exact SameDepth.leaf ks
| cons c0 cs' =>
refine SameDepth.internal ks c0 cs' ?_ (hsd c0 (by simp)) (fun c hc => hsd c (by simp [hc]))
intro c hc
rw [hht c (by simp [hc]), hht c0 (by simp)]
A node has height 0 exactly when it is a leaf (no children).
lemma heightOf_eq_zero_iff (ks : List Nat) (cs : List BTree) :
heightOf (node ks cs) = 0 ↔ cs = [] := by
cases cs with
| nil => simp [heightOf]
| cons c cs => simp [heightOf]
mergeNodes: combine two sibling subtrees around a separator key
Node merge (CLRS B-TREE-DELETE case 3b core step). Combine a left subtree,
a separator key sep, and a right subtree into one node. When both siblings are
minimal (t - 1 keys each), the merged node has exactly 2t - 1 keys — a full
node — which is the shape produced by the deletion merge repair.
def mergeNodes : BTree → Nat → BTree → BTree
| node lKeys lCh, sep, node rKeys rCh => node (lKeys ++ sep :: rKeys) (lCh ++ rCh)
mergeNodes reduces to the explicit combined node.
@[simp] lemma mergeNodes_node (lKeys rKeys : List Nat) (lCh rCh : List BTree) (sep : Nat) :
mergeNodes (node lKeys lCh) sep (node rKeys rCh) = node (lKeys ++ sep :: rKeys) (lCh ++ rCh) :=
rfl
Membership in a merged node. The keys of mergeNodes l sep r are exactly
the keys of l, the separator sep, and the keys of r.
lemma mem_keysOf_mergeNodes (l : BTree) (sep : Nat) (r : BTree) (k : Nat) :
k ∈ keysOf (mergeNodes l sep r) ↔ k ∈ keysOf l ∨ k = sep ∨ k ∈ keysOf r := by
cases l with
| node lKeys lCh =>
cases r with
| node rKeys rCh =>
simp only [mergeNodes_node, keysOf, List.mem_append, List.mem_cons,
List.flatMap_append]
tauto
Merge preserves SameDepth. Merging two equal-height same-depth siblings
yields a same-depth node. The equal-height hypothesis is exactly the invariant
supplied by SameDepth of the common parent.
lemma mergeNodes_sameDepth {left right : BTree} {sep : Nat}
(hL : SameDepth left) (hR : SameDepth right) (hht : heightOf left = heightOf right) :
SameDepth (mergeNodes left sep right) := by
cases left with
| node lKeys lCh =>
cases right with
| node rKeys rCh =>
rw [mergeNodes_node]
by_cases hlc : lCh = []
· -- left is a leaf: merged children = rCh, inherit from right
subst hlc
rw [List.nil_append]
exact sameDepth_keys_irrel hR
· by_cases hrc : rCh = []
· -- right is a leaf: merged children = lCh, inherit from left
subst hrc
rw [List.append_nil]
exact sameDepth_keys_irrel hL
· -- both internal: common child height, all same-depth
obtain ⟨a, as, rfl⟩ : ∃ a as, lCh = a :: as := by
cases lCh with
| nil => exact absurd rfl hlc
| cons a as => exact ⟨a, as, rfl⟩
obtain ⟨b, bs, rfl⟩ : ∃ b bs, rCh = b :: bs := by
cases rCh with
| nil => exact absurd rfl hrc
| cons b bs => exact ⟨b, bs, rfl⟩
have hLh : heightOf (node lKeys (a :: as)) = 1 + heightOf a :=
heightOf_internal_of_sameDepth hL
have hRh : heightOf (node rKeys (b :: bs)) = 1 + heightOf b :=
heightOf_internal_of_sameDepth hR
have hab : heightOf a = heightOf b := by rw [hLh, hRh] at hht; omega
have hL_all := sameDepth_children_eq_height hL
have hR_all := sameDepth_children_eq_height hR
refine sameDepth_of_uniform (H := heightOf a) ?_ ?_
· intro c hc
rw [List.mem_append] at hc
rcases hc with hc | hc
· exact hL_all c hc a (by simp)
· rw [hR_all c hc b (by simp), ← hab]
· intro c hc
rw [List.mem_append] at hc
rcases hc with hc | hc
· rcases List.mem_cons.mp hc with rfl | hc'
· exact sameDepth_head_sd hL
· exact sameDepth_tail_sd hL c hc'
· rcases List.mem_cons.mp hc with rfl | hc'
· exact sameDepth_head_sd hR
· exact sameDepth_tail_sd hR c hc'Merge preserves height. A merged node has the same height as either equal-height sibling. This is what lets the merge repair keep every leaf at a common depth from the perspective of the parent.
lemma mergeNodes_height {left right : BTree} {sep : Nat}
(hL : SameDepth left) (hR : SameDepth right) (hht : heightOf left = heightOf right) :
heightOf (mergeNodes left sep right) = heightOf left := by
cases left with
| node lKeys lCh =>
cases right with
| node rKeys rCh =>
rw [mergeNodes_node]
by_cases hlc : lCh = []
· -- left leaf ⇒ height 0 ⇒ right leaf ⇒ merged leaf
subst hlc
have hL0 : heightOf (node lKeys ([] : List BTree)) = 0 := by simp [heightOf]
have hR0 : heightOf (node rKeys rCh) = 0 := by rw [← hht, hL0]
have hrc : rCh = [] := (heightOf_eq_zero_iff rKeys rCh).mp hR0
subst hrc
simp [heightOf]
· obtain ⟨a, as, rfl⟩ : ∃ a as, lCh = a :: as := by
cases lCh with
| nil => exact absurd rfl hlc
| cons a as => exact ⟨a, as, rfl⟩
have hLh : heightOf (node lKeys (a :: as)) = 1 + heightOf a :=
heightOf_internal_of_sameDepth hL
have hL_all := sameDepth_children_eq_height hL
by_cases hrc : rCh = []
· subst hrc
have hR0 : heightOf (node rKeys ([] : List BTree)) = 0 := by simp [heightOf]
rw [hR0, hLh] at hht; omega
· obtain ⟨b, bs, rfl⟩ : ∃ b bs, rCh = b :: bs := by
cases rCh with
| nil => exact absurd rfl hrc
| cons b bs => exact ⟨b, bs, rfl⟩
have hRh : heightOf (node rKeys (b :: bs)) = 1 + heightOf b :=
heightOf_internal_of_sameDepth hR
have hab : heightOf a = heightOf b := by rw [hLh, hRh] at hht; omega
have hR_all := sameDepth_children_eq_height hR
-- merged children = a :: (as ++ b :: bs), all height = heightOf a
have huniform : ∀ c ∈ (as ++ b :: bs), heightOf c = heightOf a := by
intro c hc
rw [List.mem_append] at hc
rcases hc with hc | hc
· exact hL_all c (by simp [hc]) a (by simp)
· rw [hR_all c hc b (by simp), ← hab]
rw [List.cons_append, heightOf_uniform_children huniform, hLh]
mergeNodes: occupancy preservation
From ChildBounded, a node with t - 1 keys has 0 or t children.
lemma childBounded_len_of_keys {t : Nat} (ht : 1 ≤ t) {ks : List Nat} {cs : List BTree}
(h_cb : ChildBounded (node ks cs)) (hks : ks.length = t - 1) :
cs = [] ∨ cs.length = t := by
unfold ChildBounded at h_cb
rcases h_cb with ⟨hrel, _, _⟩
rcases hrel with hemp | heq
· left; cases cs with | nil => rfl | cons x xs => simp at hemp
· right; rw [heq, hks]; omega
Merge preserves Occupancy. Merging two minimal siblings (t - 1 keys
each) produces a full non-root node: 2t - 1 keys and either 0 or 2t
children. This is the occupancy face of CLRS deletion case 3b.
lemma mergeNodes_occupancy {t : Nat} (ht : 2 ≤ t)
{lKeys rKeys : List Nat} {lCh rCh : List BTree} {sep : Nat}
(hlk : lKeys.length = t - 1) (hrk : rKeys.length = t - 1)
(hL_cb : ChildBounded (node lKeys lCh)) (hR_cb : ChildBounded (node rKeys rCh))
(hL_occ : Occupancy t false (node lKeys lCh))
(hR_occ : Occupancy t false (node rKeys rCh)) :
Occupancy t false (mergeNodes (node lKeys lCh) sep (node rKeys rCh)) := by
rw [mergeNodes_node]
have hlc : lCh = [] ∨ lCh.length = t := childBounded_len_of_keys (by omega) hL_cb hlk
have hrc : rCh = [] ∨ rCh.length = t := childBounded_len_of_keys (by omega) hR_cb hrk
have hL_sub : ∀ c ∈ lCh, Occupancy t false c := by
unfold Occupancy at hL_occ; obtain ⟨-, -, -, h⟩ := hL_occ; exact h
have hR_sub : ∀ c ∈ rCh, Occupancy t false c := by
unfold Occupancy at hR_occ; obtain ⟨-, -, -, h⟩ := hR_occ; exact h
have hkeys_len : (lKeys ++ sep :: rKeys).length = 2 * t - 1 := by
simp only [List.length_append, List.length_cons]; omega
have h_children_bound :
((lCh ++ rCh).isEmpty = true) ∨ (t ≤ (lCh ++ rCh).length ∧ (lCh ++ rCh).length ≤ 2 * t) := by
rcases hlc with h0 | hlt <;> rcases hrc with h0' | hrt
· left; rw [h0, h0']; rfl
· right; subst h0; rw [List.nil_append, hrt]; exact ⟨le_rfl, by omega⟩
· right; subst h0'; rw [List.append_nil, hlt]; exact ⟨le_rfl, by omega⟩
· right; rw [List.length_append, hlt, hrt]; exact ⟨by omega, by omega⟩
unfold Occupancy
refine ⟨?_, ?_, h_children_bound, ?_⟩
· -- lower bound t - 1 ≤ keys.length
have h : t - 1 ≤ (lKeys ++ sep :: rKeys).length := by rw [hkeys_len]; omega
exact h
· -- upper bound keys.length ≤ 2t - 1
have h : (lKeys ++ sep :: rKeys).length ≤ 2 * t - 1 := by rw [hkeys_len]
exact h
· -- sub-child occupancy inherited from the two siblings
intro c hc
rw [List.mem_append] at hc
rcases hc with hc | hc
· exact hL_sub c hc
· exact hR_sub c hc
mergeNodes preserves ChildBounded
Merge preserves ChildBounded. Merging two sibling subtrees around a
separator yields a node whose children count and key bounds satisfy
ChildBounded. The shape-compatibility hypothesis hshape (both siblings are
leaves, or both are internal) is necessary: merging a leaf with an internal
node cannot satisfy the children-count invariant.
lemma mergeNodes_childBounded
{lKeys rKeys : List Nat} {lCh rCh : List BTree} {sep : Nat}
(hL_cb : ChildBounded (node lKeys lCh)) (hR_cb : ChildBounded (node rKeys rCh))
(hshape : (lCh = []) ↔ (rCh = []))
(hL_le : ∀ k ∈ keysOf (node lKeys lCh), k ≤ sep)
(hR_ge : ∀ k ∈ keysOf (node rKeys rCh), sep ≤ k) :
ChildBounded (mergeNodes (node lKeys lCh) sep (node rKeys rCh)) := by
rw [mergeNodes_node]
unfold ChildBounded at hL_cb hR_cb ⊢
obtain ⟨hL_rel, hL_bounds, hL_sub⟩ := hL_cb
obtain ⟨hR_rel, hR_bounds, hR_sub⟩ := hR_cb
have hL_len : lCh = [] ∨ lCh.length = lKeys.length + 1 := by
rcases hL_rel with hLe | hLlen
· left; cases lCh with | nil => rfl | cons x xs => simp at hLe
· right; exact hLlen
have hR_len : rCh = [] ∨ rCh.length = rKeys.length + 1 := by
rcases hR_rel with hRe | hRlen
· left; cases rCh with | nil => rfl | cons x xs => simp at hRe
· right; exact hRlen
refine ⟨?_, ?_, ?_⟩
· -- component 1: children count
rcases hL_len with hl | hLlen
· rcases hR_len with hr | hRlen
· left; subst hl; subst hr; rfl
· -- lCh empty, rCh internal: contradicts hshape
have hr0 : rCh = [] := hshape.mp hl
subst hl; rw [hr0] at hRlen; simp at hRlen
· rcases hR_len with hr | hRlen
· -- lCh internal, rCh empty: contradicts hshape
have hl0 : lCh = [] := hshape.mpr hr
subst hr; rw [hl0] at hLlen; simp at hLlen
· right
rw [List.length_append, List.length_append, List.length_cons, hLlen, hRlen]
omega
· -- component 2: per-child key bounds
intro i hi
by_cases hlCh : lCh = []
· have hrCh : rCh = [] := hshape.mp hlCh
subst hlCh; subst hrCh; simp at hi
· have hrCh : rCh ≠ [] := fun h => hlCh (hshape.mpr h)
have hLlen : lCh.length = lKeys.length + 1 := by
rcases hL_len with h | h
· exact absurd h hlCh
· exact h
have hRlen : rCh.length = rKeys.length + 1 := by
rcases hR_len with h | h
· exact absurd h hrCh
· exact h
refine ⟨?_, ?_⟩
· -- lower bound: mergedKeys[i-1]? bounds child i from below
rcases Nat.eq_zero_or_pos i with hi0 | hipos
· exact Or.inl hi0
· right
by_cases hiL : i < lCh.length
· -- child in the left segment
have hi1 : i - 1 < lKeys.length := by omega
have hchild : (lCh ++ rCh).get ⟨i, hi⟩ = lCh.get ⟨i, hiL⟩ :=
List.getElem_append_left hiL
have heq : (lKeys ++ sep :: rKeys)[i-1]? = lKeys[i-1]? :=
List.getElem?_append_left (by omega)
rw [heq, List.getElem?_eq_getElem hi1]
have hb := (hL_bounds i hiL).1
rcases hb with h0 | hb
· omega
· simp only [List.getElem?_eq_getElem hi1] at hb
intro k hk
rw [hchild] at hk
exact hb k hk
· -- child in the right segment
have hiL' : lCh.length ≤ i := Nat.le_of_not_lt hiL
have hjlt : i - lCh.length < rCh.length := by
rw [List.length_append] at hi; omega
have hchild : (lCh ++ rCh).get ⟨i, hi⟩ = rCh.get ⟨i - lCh.length, hjlt⟩ :=
List.getElem_append_right hiL'
have heq : (lKeys ++ sep :: rKeys)[i-1]? = (sep :: rKeys)[i - lCh.length]? := by
rw [List.getElem?_append_right (by omega : lKeys.length ≤ i - 1)]
have e : i - 1 - lKeys.length = i - lCh.length := by omega
rw [e]
rw [heq]
rcases Nat.eq_zero_or_pos (i - lCh.length) with hj0 | hjpos
· -- child is rCh[0]: lower key is the separator
have h0 : (sep :: rKeys)[i - lCh.length]? = some sep := by simp [hj0]
rw [h0]
intro k hk
rw [hchild] at hk
have hmem : k ∈ keysOf (node rKeys rCh) := by
simp only [keysOf, List.mem_append, List.mem_flatMap]
exact Or.inr ⟨rCh.get ⟨i - lCh.length, hjlt⟩, List.getElem_mem _, hk⟩
exact hR_ge k hmem
· -- child is rCh[j], j ≥ 1: lower key is rKeys[j-1]
have hj1 : i - lCh.length - 1 < rKeys.length := by omega
have hcons : (sep :: rKeys)[i - lCh.length]? = rKeys[i - lCh.length - 1]? := by
conv_lhs =>
rw [show i - lCh.length = (i - lCh.length - 1) + 1 from by omega]
exact List.getElem?_cons_succ
rw [hcons, List.getElem?_eq_getElem hj1]
have hb := (hR_bounds (i - lCh.length) hjlt).1
rcases hb with h0 | hb
· omega
· simp only [List.getElem?_eq_getElem hj1] at hb
intro k hk
rw [hchild] at hk
exact hb k hk
· -- upper bound: mergedKeys[i]? bounds child i from above
by_cases hiL : i < lCh.length
· -- child in the left segment
have hchild : (lCh ++ rCh).get ⟨i, hi⟩ = lCh.get ⟨i, hiL⟩ :=
List.getElem_append_left hiL
by_cases hiK : i < lKeys.length
· -- upper key is lKeys[i]
have heq : (lKeys ++ sep :: rKeys)[i]? = lKeys[i]? :=
List.getElem?_append_left hiK
rw [heq, List.getElem?_eq_getElem hiK]
have hub := (hL_bounds i hiL).2
simp only [List.getElem?_eq_getElem hiK] at hub
intro k hk
rw [hchild] at hk
exact hub k hk
· -- child is lCh[lKeys.length]: upper key is the separator
have hieq : i = lKeys.length := by omega
have heq : (lKeys ++ sep :: rKeys)[i]? = some sep := by
rw [hieq, List.getElem?_append_right (Nat.le_refl _)]
simp
rw [heq]
intro k hk
rw [hchild] at hk
have hmem : k ∈ keysOf (node lKeys lCh) := by
simp only [keysOf, List.mem_append, List.mem_flatMap]
exact Or.inr ⟨lCh.get ⟨i, hiL⟩, List.getElem_mem _, hk⟩
exact hL_le k hmem
· -- child in the right segment
have hiL' : lCh.length ≤ i := Nat.le_of_not_lt hiL
have hjlt : i - lCh.length < rCh.length := by
rw [List.length_append] at hi; omega
have hchild : (lCh ++ rCh).get ⟨i, hi⟩ = rCh.get ⟨i - lCh.length, hjlt⟩ :=
List.getElem_append_right hiL'
have heq : (lKeys ++ sep :: rKeys)[i]? = rKeys[i - lCh.length]? := by
rw [List.getElem?_append_right (by omega : lKeys.length ≤ i)]
conv_lhs =>
rw [show i - lKeys.length = (i - lCh.length) + 1 from by omega]
exact List.getElem?_cons_succ
rw [heq]
by_cases hjK : i - lCh.length < rKeys.length
· -- upper key is rKeys[j]
rw [List.getElem?_eq_getElem hjK]
have hub := (hR_bounds (i - lCh.length) hjlt).2
simp only [List.getElem?_eq_getElem hjK] at hub
intro k hk
rw [hchild] at hk
exact hub k hk
· -- child is rCh[rKeys.length]: no upper key
have hnone : rKeys[i - lCh.length]? = none :=
List.getElem?_eq_none (by omega)
rw [hnone]
exact trivial
· -- component 3: recursive ChildBounded on children
intro c hc
rw [List.mem_append] at hc
rcases hc with hc | hc
· exact hL_sub c hc
· exact hR_sub c hc
mergeNodes preserves Sorted
lemma mergeNodes_sorted {lKeys rKeys : List Nat} {lCh rCh : List BTree} {sep : Nat}
(hL_s : Sorted (node lKeys lCh)) (hR_s : Sorted (node rKeys rCh))
(hL_le : ∀ k ∈ keysOf (node lKeys lCh), k ≤ sep)
(hR_ge : ∀ k ∈ keysOf (node rKeys rCh), sep ≤ k) :
Sorted (mergeNodes (node lKeys lCh) sep (node rKeys rCh)) := by
rw [mergeNodes_node]
unfold Sorted; unfold Sorted at hL_s hR_s
obtain ⟨hL_pw, hL_ch⟩ := hL_s
obtain ⟨hR_pw, hR_ch⟩ := hR_s
refine ⟨?_, ?_⟩
· have hL_all : ∀ k ∈ lKeys, k ≤ sep := by
intro k hk; apply hL_le k; simp [keysOf, hk]
have hR_all : ∀ k ∈ rKeys, sep ≤ k := by
intro k hk; apply hR_ge k; simp [keysOf, hk]
have h_sep_rKeys_pw : List.Pairwise (· ≤ ·) (sep :: rKeys) :=
List.Pairwise.cons hR_all hR_pw
have h_cross : ∀ a ∈ lKeys, ∀ b ∈ sep :: rKeys, a ≤ b := by
intro a ha b hb
rcases List.mem_cons.mp hb with (rfl | hb_rKeys)
· exact hL_all a ha
· exact le_trans (hL_all a ha) (hR_all b hb_rKeys)
rw [List.pairwise_append]
exact ⟨hL_pw, h_sep_rKeys_pw, h_cross⟩
· intro c hc
rw [List.mem_append] at hc
rcases hc with hc | hc
· exact hL_ch c hc
· exact hR_ch c hcStructural preservation architecture
The raw operation may leave an empty root containing one child, so the
mathematically correct root postcondition is RootDeleteResult, not raw
WellFormed. Local rotation and merge facts are packaged in
Repair, then lifted through parent contexts by the reassembly modules.
ComposedPreservation performs one induction over every executable
branch and exposes non-root and raw-root results. Finally,
WellFormed proves that composedDeleteRoot contracts the permitted
transient and restores genuine root well-formedness.
From ChildBounded, a node either has no children or has exactly one more
child than keys.
lemma childBounded_children_rel {ks : List Nat} {cs : List BTree}
(h_cb : ChildBounded (node ks cs)) : cs = [] ∨ cs.length = ks.length + 1 := by
unfold ChildBounded at h_cb
rcases h_cb with ⟨hrel, _, _⟩
rcases hrel with hemp | heq
· left; cases cs with | nil => rfl | cons x xs => simp at hemp
· right; exact heqOccupancy (de)constructors and shared repair infrastructure
Destructor for a non-root Occupancy fact into its four plain components.
lemma occupancy_false_dest {t : Nat} {ks : List Nat} {cs : List BTree}
(h : Occupancy t false (node ks cs)) :
t - 1 ≤ ks.length ∧ ks.length ≤ 2 * t - 1 ∧
(cs = [] ∨ (t ≤ cs.length ∧ cs.length ≤ 2 * t)) ∧ (∀ c ∈ cs, Occupancy t false c) := by
unfold Occupancy at h
obtain ⟨h1, h2, h3, h4⟩ := h
refine ⟨h1, h2, ?_, h4⟩
rcases h3 with he | hb
· left; cases cs with | nil => rfl | cons x xs => simp at he
· right; exact hb
Constructor for a non-root Occupancy fact from its four plain components.
lemma occupancy_false_intro {t : Nat} {ks : List Nat} {cs : List BTree}
(h1 : t - 1 ≤ ks.length) (h2 : ks.length ≤ 2 * t - 1)
(h3 : cs = [] ∨ (t ≤ cs.length ∧ cs.length ≤ 2 * t))
(h4 : ∀ c ∈ cs, Occupancy t false c) :
Occupancy t false (node ks cs) := by
unfold Occupancy
refine ⟨h1, h2, ?_, h4⟩
rcases h3 with he | hb
· left; rw [he]; rfl
· right; exact hb
Each child of a SameDepth node is itself SameDepth.
lemma sameDepth_children_sd {ks : List Nat} {cs : List BTree}
(h : SameDepth (node ks cs)) : ∀ c ∈ cs, SameDepth c := by
cases h with
| leaf _ => intro c hc; simp at hc
| internal _ c0 cs' _ hsd0 hsds =>
intro c hc
rcases List.mem_cons.mp hc with rfl | hc'
· exact hsd0
· exact hsds c hc'Two equal-height sibling subtrees are simultaneously leaves or simultaneously internal.
lemma leaf_iff_of_height_eq {lKeys rKeys : List Nat} {lCh rCh : List BTree}
(hht : heightOf (node lKeys lCh) = heightOf (node rKeys rCh)) :
lCh = [] ↔ rCh = [] := by
rw [← heightOf_eq_zero_iff lKeys lCh, ← heightOf_eq_zero_iff rKeys rCh, hht]Any child of the left sibling has the same height as any child of the right sibling, given the two siblings have equal height.
lemma child_height_bridge {lKeys rKeys : List Nat} {lCh rCh : List BTree}
(hL : SameDepth (node lKeys lCh)) (hR : SameDepth (node rKeys rCh))
(hht : heightOf (node lKeys lCh) = heightOf (node rKeys rCh))
{c d : BTree} (hc : c ∈ lCh) (hd : d ∈ rCh) : heightOf c = heightOf d := by
obtain ⟨a, as, rfl⟩ : ∃ a as, lCh = a :: as := by
cases lCh with
| nil => simp at hc
| cons a as => exact ⟨a, as, rfl⟩
obtain ⟨b, bs, rfl⟩ : ∃ b bs, rCh = b :: bs := by
cases rCh with
| nil => simp at hd
| cons b bs => exact ⟨b, bs, rfl⟩
have hLh : heightOf (node lKeys (a :: as)) = 1 + heightOf a := heightOf_internal_of_sameDepth hL
have hRh : heightOf (node rKeys (b :: bs)) = 1 + heightOf b := heightOf_internal_of_sameDepth hR
have hab : heightOf a = heightOf b := by rw [hLh, hRh] at hht; omega
have hca : heightOf c = heightOf a := sameDepth_children_eq_height hL c hc a (by simp)
have hdb : heightOf d = heightOf b := sameDepth_children_eq_height hR d hd b (by simp)
rw [hca, hdb, hab]
rotateRight: borrow a key from the right sibling (CLRS case 3a)
Borrow from the right sibling (CLRS B-TREE-DELETE case 3a). The
underflowing left child receives the separator sep as a new last key and the
right sibling's first child; the right sibling's first key rises to become the
new separator. Returns (newLeft, newSep, newRight).
def rotateRight : BTree → Nat → BTree → BTree × Nat × BTree
| node lKeys lCh, sep, node rKeys rCh =>
match rKeys with
| [] => (node lKeys lCh, sep, node rKeys rCh)
| rHead :: rTail =>
(node (lKeys ++ [sep]) (lCh ++ rCh.take 1), rHead, node rTail (rCh.drop 1))
rotateRight reduces on a right sibling with at least one key.
@[simp] lemma rotateRight_cons (lKeys rTail : List Nat) (lCh rCh : List BTree)
(sep rHead : Nat) :
rotateRight (node lKeys lCh) sep (node (rHead :: rTail) rCh) =
(node (lKeys ++ [sep]) (lCh ++ rCh.take 1), rHead, node rTail (rCh.drop 1)) := rfl
rotateRight new-left node is well formed. After borrowing, the repaired
left child has exactly t keys — above the minimum — and preserves SameDepth
and its height. The equal-height hypothesis is supplied by the parent's
SameDepth invariant.
lemma rotateRight_left {t : Nat} (ht : 2 ≤ t)
{lKeys rKeys : List Nat} {lCh rCh : List BTree} {sep : Nat}
(hlk : lKeys.length = t - 1)
(hL_cb : ChildBounded (node lKeys lCh))
(hL : SameDepth (node lKeys lCh)) (hR : SameDepth (node rKeys rCh))
(hL_occ : Occupancy t false (node lKeys lCh))
(hR_occ : Occupancy t false (node rKeys rCh))
(hht : heightOf (node lKeys lCh) = heightOf (node rKeys rCh)) :
Occupancy t false (node (lKeys ++ [sep]) (lCh ++ rCh.take 1)) ∧
SameDepth (node (lKeys ++ [sep]) (lCh ++ rCh.take 1)) ∧
heightOf (node (lKeys ++ [sep]) (lCh ++ rCh.take 1)) = heightOf (node lKeys lCh) := by
obtain ⟨_, _, _, hL_sub⟩ := occupancy_false_dest hL_occ
obtain ⟨_, _, _, hR_sub⟩ := occupancy_false_dest hR_occ
have hkeys_len : (lKeys ++ [sep]).length = t := by
simp only [List.length_append, List.length_cons, List.length_nil, hlk]; omega
by_cases hlc : lCh = []
· -- both siblings are leaves: no child moves
have hrc : rCh = [] := (leaf_iff_of_height_eq hht).mp hlc
subst hlc; subst hrc
simp only [List.nil_append, List.take_nil, List.append_nil]
refine ⟨?_, SameDepth.leaf _, ?_⟩
· exact occupancy_false_intro (by rw [hkeys_len]; omega) (by rw [hkeys_len]; omega) (Or.inl rfl)
(by intro c hc; simp at hc)
· simp [heightOf]
· -- both internal: one child rotates over
obtain ⟨a, as, rfl⟩ : ∃ a as, lCh = a :: as := by
cases lCh with
| nil => exact absurd rfl hlc
| cons a as => exact ⟨a, as, rfl⟩
have hrc_ne : rCh ≠ [] := fun h => hlc ((leaf_iff_of_height_eq hht).mpr h)
obtain ⟨b, bs, rfl⟩ : ∃ b bs, rCh = b :: bs := by
cases rCh with
| nil => exact absurd rfl hrc_ne
| cons b bs => exact ⟨b, bs, rfl⟩
have htake : (b :: bs).take 1 = [b] := rfl
rw [htake]
have hlen : (a :: as).length = t := by
rcases childBounded_len_of_keys (by omega) hL_cb hlk with h | h
· exact absurd h (by simp)
· exact h
have hchildren_len : ((a :: as) ++ [b]).length = t + 1 := by
rw [List.length_append, hlen]; rfl
-- heights: every element of the new children list has height `heightOf a`
have hb_ht : heightOf b = heightOf a :=
(child_height_bridge hL hR hht (c := a) (d := b) (by simp) (by simp)).symm
have huniform : ∀ c ∈ ((a :: as) ++ [b]), heightOf c = heightOf a := by
intro c hc
rw [List.mem_append] at hc
rcases hc with hc | hc
· exact sameDepth_children_eq_height hL c hc a (by simp)
· simp only [List.mem_singleton] at hc; rw [hc]; exact hb_ht
have hsd_all : ∀ c ∈ ((a :: as) ++ [b]), SameDepth c := by
intro c hc
rw [List.mem_append] at hc
rcases hc with hc | hc
· exact sameDepth_children_sd hL c hc
· simp only [List.mem_singleton] at hc; rw [hc]; exact sameDepth_children_sd hR b (by simp)
have huniform_tail : ∀ c ∈ (as ++ [b]), heightOf c = heightOf a := by
intro c hc; exact huniform c (by rw [List.cons_append]; exact List.mem_cons_of_mem a hc)
refine ⟨?_, ?_, ?_⟩
· -- occupancy: t keys, t+1 children
refine occupancy_false_intro (by rw [hkeys_len]; omega) (by rw [hkeys_len]; omega)
(Or.inr ⟨by rw [hchildren_len]; omega, by rw [hchildren_len]; omega⟩) ?_
· intro c hc
rw [List.mem_append] at hc
rcases hc with hc | hc
· exact hL_sub c hc
· simp only [List.mem_singleton] at hc; rw [hc]; exact hR_sub b (by simp)
· exact sameDepth_of_uniform (H := heightOf a) huniform hsd_all
· rw [List.cons_append, heightOf_uniform_children huniform_tail,
heightOf_internal_of_sameDepth hL]
rotateRight new-right node is well formed. After the borrow, the right
sibling has one fewer key (still at least t - 1) and preserves SameDepth and
its height.
lemma rotateRight_right {t : Nat} (ht : 2 ≤ t)
{rHead : Nat} {rTail : List Nat} {rCh : List BTree}
(hrlen : t ≤ (rHead :: rTail).length)
(hR_cb : ChildBounded (node (rHead :: rTail) rCh))
(hR_occ : Occupancy t false (node (rHead :: rTail) rCh))
(hR : SameDepth (node (rHead :: rTail) rCh)) :
Occupancy t false (node rTail (rCh.drop 1)) ∧
SameDepth (node rTail (rCh.drop 1)) ∧
heightOf (node rTail (rCh.drop 1)) = heightOf (node (rHead :: rTail) rCh) := by
obtain ⟨_, hR_up, _, hR_sub⟩ := occupancy_false_dest hR_occ
have hrtail : t - 1 ≤ rTail.length := by simp only [List.length_cons] at hrlen; omega
have hrup : rTail.length ≤ 2 * t - 1 := by simp only [List.length_cons] at hR_up; omega
by_cases hrc : rCh = []
· -- right sibling is a leaf
subst hrc
simp only [List.drop_nil]
refine ⟨occupancy_false_intro hrtail hrup (Or.inl rfl) (by intro c hc; simp at hc),
SameDepth.leaf _, ?_⟩
simp [heightOf]
· obtain ⟨c0, cs, rfl⟩ : ∃ c0 cs, rCh = c0 :: cs := by
cases rCh with
| nil => exact absurd rfl hrc
| cons c0 cs => exact ⟨c0, cs, rfl⟩
have hdrop : (c0 :: cs).drop 1 = cs := rfl
rw [hdrop]
-- `cs` is nonempty because the internal node has ≥ t ≥ 2 children
have hchlen : (c0 :: cs).length = (rHead :: rTail).length + 1 := by
rcases childBounded_children_rel hR_cb with h | h
· exact absurd h (by simp)
· exact h
have hcs_ne : cs ≠ [] := by
intro h; rw [h] at hchlen; simp only [List.length_cons, List.length_nil] at hchlen; omega
obtain ⟨d0, ds, rfl⟩ : ∃ d0 ds, cs = d0 :: ds := by
cases cs with
| nil => exact absurd rfl hcs_ne
| cons d0 ds => exact ⟨d0, ds, rfl⟩
have huniform : ∀ c ∈ (d0 :: ds), heightOf c = heightOf d0 := by
intro c hc
exact sameDepth_children_eq_height hR c (by simp [hc]) d0 (by simp)
have hsd_all : ∀ c ∈ (d0 :: ds), SameDepth c := by
intro c hc; exact sameDepth_children_sd hR c (by simp [hc])
have hd0c0 : heightOf d0 = heightOf c0 :=
sameDepth_children_eq_height hR d0 (by simp) c0 (by simp)
have huniform_ds : ∀ c ∈ ds, heightOf c = heightOf d0 :=
fun c hc => huniform c (List.mem_cons_of_mem d0 hc)
refine ⟨?_, ?_, ?_⟩
· -- occupancy: rTail.length keys, rTail.length+1 children
have hchild_len : (d0 :: ds).length = rTail.length + 1 := by
simp only [List.length_cons] at hchlen ⊢; omega
refine occupancy_false_intro hrtail hrup (Or.inr ?_) ?_
· rw [hchild_len]; exact ⟨by omega, by omega⟩
· intro c hc; exact hR_sub c (List.mem_cons_of_mem c0 hc)
· exact sameDepth_of_uniform (H := heightOf d0) huniform hsd_all
· rw [heightOf_uniform_children huniform_ds,
heightOf_internal_of_sameDepth hR, hd0c0]
rotateRight preserves every node-level invariant. Both nodes produced by
the borrow (the repaired child and the trimmed sibling) satisfy Occupancy,
SameDepth, and keep their original heights. This is the full node-level
statement of CLRS deletion case 3a.
theorem rotateRight_preserves {t : Nat} (ht : 2 ≤ t)
{lKeys rKeys : List Nat} {lCh rCh : List BTree} {sep : Nat}
(hlk : lKeys.length = t - 1) (hrlen : t ≤ rKeys.length)
(hL_cb : ChildBounded (node lKeys lCh)) (hR_cb : ChildBounded (node rKeys rCh))
(hL : SameDepth (node lKeys lCh)) (hR : SameDepth (node rKeys rCh))
(hL_occ : Occupancy t false (node lKeys lCh)) (hR_occ : Occupancy t false (node rKeys rCh))
(hht : heightOf (node lKeys lCh) = heightOf (node rKeys rCh)) :
(Occupancy t false (rotateRight (node lKeys lCh) sep (node rKeys rCh)).1 ∧
SameDepth (rotateRight (node lKeys lCh) sep (node rKeys rCh)).1 ∧
heightOf (rotateRight (node lKeys lCh) sep (node rKeys rCh)).1 = heightOf (node lKeys lCh)) ∧
(Occupancy t false (rotateRight (node lKeys lCh) sep (node rKeys rCh)).2.2 ∧
SameDepth (rotateRight (node lKeys lCh) sep (node rKeys rCh)).2.2 ∧
heightOf (rotateRight (node lKeys lCh) sep (node rKeys rCh)).2.2 = heightOf (node rKeys rCh)) := by
obtain ⟨rHead, rTail, rfl⟩ : ∃ rHead rTail, rKeys = rHead :: rTail := by
cases rKeys with
| nil => simp only [List.length_nil] at hrlen; omega
| cons rHead rTail => exact ⟨rHead, rTail, rfl⟩
simp only [rotateRight_cons]
exact ⟨rotateRight_left ht hlk hL_cb hL hR hL_occ hR_occ hht,
rotateRight_right ht hrlen hR_cb hR_occ hR⟩
rotateLeft: borrow a key from the left sibling (CLRS case 3a, symmetric)
Borrow from the left sibling (CLRS B-TREE-DELETE case 3a, symmetric to
rotateRight). The underflowing right child receives the separator sep
as a new first key and the left sibling's last child; the left sibling's last
key rises to become the new separator. Returns (newLeft, newSep, newRight).
def rotateLeft : BTree → Nat → BTree → BTree × Nat × BTree
| node lKeys lCh, sep, node rKeys rCh =>
match lKeys with
| [] => (node lKeys lCh, sep, node rKeys rCh)
| lHead :: lTail =>
(node (lHead :: lTail).dropLast (lCh.take (lCh.length - 1)),
(lHead :: lTail).getLast (List.cons_ne_nil _ _),
node (sep :: rKeys) ((lCh.drop (lCh.length - 1)) ++ rCh))
rotateLeft reduces on a left sibling with no keys (identity case).
@[simp] lemma rotateLeft_nil (rKeys : List Nat) (lCh rCh : List BTree) (sep : Nat) :
rotateLeft (node [] lCh) sep (node rKeys rCh) = (node [] lCh, sep, node rKeys rCh) := rfl
rotateLeft reduces on a left sibling with at least one key.
@[simp] lemma rotateLeft_cons (lHead : Nat) (lTail rKeys : List Nat)
(lCh rCh : List BTree) (sep : Nat) :
rotateLeft (node (lHead :: lTail) lCh) sep (node rKeys rCh) =
(node (lHead :: lTail).dropLast (lCh.take (lCh.length - 1)),
(lHead :: lTail).getLast (List.cons_ne_nil _ _),
node (sep :: rKeys) ((lCh.drop (lCh.length - 1)) ++ rCh)) := rfl
rotateLeft new-left node is well formed. After the borrow, the left
sibling has one fewer key (still at least t - 1) and preserves SameDepth
and its height. Mirrors rotateRight_right.
lemma rotateLeft_left {t : Nat} (ht : 2 ≤ t)
{lHead : Nat} {lTail : List Nat} {lCh : List BTree}
(hllen : t ≤ (lHead :: lTail).length)
(hL_cb : ChildBounded (node (lHead :: lTail) lCh))
(hL_occ : Occupancy t false (node (lHead :: lTail) lCh))
(hL : SameDepth (node (lHead :: lTail) lCh)) :
Occupancy t false (node (lHead :: lTail).dropLast (lCh.take (lCh.length - 1))) ∧
SameDepth (node (lHead :: lTail).dropLast (lCh.take (lCh.length - 1))) ∧
heightOf (node (lHead :: lTail).dropLast (lCh.take (lCh.length - 1))) =
heightOf (node (lHead :: lTail) lCh) := by
obtain ⟨_, hL_up, _, hL_sub⟩ := occupancy_false_dest hL_occ
have hkeys_len : (lHead :: lTail).dropLast.length = lTail.length := by
rw [List.length_dropLast, List.length_cons]; omega
have hltail_lo : t - 1 ≤ lTail.length := by
simp only [List.length_cons] at hllen; omega
have hltail_up : lTail.length ≤ 2 * t - 1 := by
simp only [List.length_cons] at hL_up; omega
by_cases hlc : lCh = []
· -- left sibling is a leaf: no child moves
subst hlc
simp only [List.take_nil]
refine ⟨occupancy_false_intro (by rw [hkeys_len]; omega) (by rw [hkeys_len]; omega)
(Or.inl rfl) (by intro c hc; simp at hc), SameDepth.leaf _, ?_⟩
simp [heightOf]
· -- internal: the last child rotates over
obtain ⟨c0, cs, rfl⟩ : ∃ c0 cs, lCh = c0 :: cs := by
cases lCh with
| nil => exact absurd rfl hlc
| cons c0 cs => exact ⟨c0, cs, rfl⟩
have hchlen : (c0 :: cs).length = (lHead :: lTail).length + 1 := by
rcases childBounded_children_rel hL_cb with h | h
· exact absurd h (by simp)
· exact h
have htake_len : ((c0 :: cs).take ((c0 :: cs).length - 1)).length =
(c0 :: cs).length - 1 := by
rw [List.length_take]; omega
have htake_ne : (c0 :: cs).take ((c0 :: cs).length - 1) ≠ [] := by
intro h
rw [h] at htake_len
simp only [List.length_nil] at htake_len
omega
obtain ⟨d0, ds, htd⟩ : ∃ d0 ds, (c0 :: cs).take ((c0 :: cs).length - 1) =
d0 :: ds := by
cases h : (c0 :: cs).take ((c0 :: cs).length - 1) with
| nil => exact absurd h htake_ne
| cons d0 ds => exact ⟨d0, ds, rfl⟩
have hmem_take : ∀ c ∈ (c0 :: cs).take ((c0 :: cs).length - 1), c ∈ (c0 :: cs) :=
fun c hc => List.mem_of_mem_take hc
have htake_len' : ((c0 :: cs).take ((c0 :: cs).length - 1)).length =
lTail.length + 1 := by
rw [htake_len, hchlen]; simp only [List.length_cons]; omega
rw [htd]
have hd0_mem : d0 ∈ (c0 :: cs) := hmem_take d0 (by rw [htd]; simp)
have huniform : ∀ c ∈ (d0 :: ds), heightOf c = heightOf d0 := by
intro c hc
have hc' : c ∈ (c0 :: cs) := hmem_take c (by rw [htd]; exact hc)
exact sameDepth_children_eq_height hL c hc' d0 hd0_mem
have hsd_all : ∀ c ∈ (d0 :: ds), SameDepth c := by
intro c hc
exact sameDepth_children_sd hL c (hmem_take c (by rw [htd]; exact hc))
have huniform_ds : ∀ c ∈ ds, heightOf c = heightOf d0 :=
fun c hc => huniform c (List.mem_cons_of_mem d0 hc)
have hd0c0 : heightOf d0 = heightOf c0 :=
sameDepth_children_eq_height hL d0 hd0_mem c0 (by simp)
have hchild_len : (d0 :: ds).length = lTail.length + 1 := by
rw [← htd]; exact htake_len'
refine ⟨?_, ?_, ?_⟩
· -- occupancy: lTail.length keys, lTail.length + 1 children
refine occupancy_false_intro (by rw [hkeys_len]; omega) (by rw [hkeys_len]; omega)
(Or.inr ?_) ?_
· rw [hchild_len]; exact ⟨by omega, by omega⟩
· intro c hc
exact hL_sub c (hmem_take c (by rw [htd]; exact hc))
· exact sameDepth_of_uniform (H := heightOf d0) huniform hsd_all
· rw [heightOf_uniform_children huniform_ds, heightOf_internal_of_sameDepth hL, hd0c0]
rotateLeft new-right node is well formed. After borrowing, the repaired
right child has exactly t keys — above the minimum — and preserves
SameDepth and its height. The equal-height hypothesis is supplied by the
parent's SameDepth invariant. Mirrors rotateRight_left.
lemma rotateLeft_right {t : Nat} (ht : 2 ≤ t)
{lKeys rKeys : List Nat} {lCh rCh : List BTree} {sep : Nat}
(hrk : rKeys.length = t - 1)
(hR_cb : ChildBounded (node rKeys rCh))
(hL : SameDepth (node lKeys lCh)) (hR : SameDepth (node rKeys rCh))
(hL_occ : Occupancy t false (node lKeys lCh))
(hR_occ : Occupancy t false (node rKeys rCh))
(hht : heightOf (node lKeys lCh) = heightOf (node rKeys rCh)) :
Occupancy t false (node (sep :: rKeys) ((lCh.drop (lCh.length - 1)) ++ rCh)) ∧
SameDepth (node (sep :: rKeys) ((lCh.drop (lCh.length - 1)) ++ rCh)) ∧
heightOf (node (sep :: rKeys) ((lCh.drop (lCh.length - 1)) ++ rCh)) =
heightOf (node rKeys rCh) := by
obtain ⟨_, _, _, hL_sub⟩ := occupancy_false_dest hL_occ
obtain ⟨_, _, _, hR_sub⟩ := occupancy_false_dest hR_occ
have hkeys_len : (sep :: rKeys).length = t := by
simp only [List.length_cons, hrk]; omega
by_cases hrc : rCh = []
· -- both siblings are leaves: no child moves
have hlc : lCh = [] := (leaf_iff_of_height_eq hht).mpr hrc
subst hlc; subst hrc
simp only [List.drop_nil, List.nil_append]
refine ⟨?_, SameDepth.leaf _, ?_⟩
· exact occupancy_false_intro (by rw [hkeys_len]; omega) (by rw [hkeys_len]; omega)
(Or.inl rfl) (by intro c hc; simp at hc)
· simp [heightOf]
· -- both internal: one child rotates over
obtain ⟨b, bs, rfl⟩ : ∃ b bs, rCh = b :: bs := by
cases rCh with
| nil => exact absurd rfl hrc
| cons b bs => exact ⟨b, bs, rfl⟩
have hlc_ne : lCh ≠ [] := fun h => hrc ((leaf_iff_of_height_eq hht).mp h)
obtain ⟨a, as, rfl⟩ : ∃ a as, lCh = a :: as := by
cases lCh with
| nil => exact absurd rfl hlc_ne
| cons a as => exact ⟨a, as, rfl⟩
have hdrop_len : ((a :: as).drop ((a :: as).length - 1)).length = 1 := by
rw [List.length_drop]
have hpos : 0 < (a :: as).length := Nat.zero_lt_succ _
omega
have hdrop_ne : (a :: as).drop ((a :: as).length - 1) ≠ [] := by
intro h; rw [h] at hdrop_len; simp at hdrop_len
obtain ⟨d0, ds, hdd⟩ : ∃ d0 ds, (a :: as).drop ((a :: as).length - 1) =
d0 :: ds := by
cases h : (a :: as).drop ((a :: as).length - 1) with
| nil => exact absurd h hdrop_ne
| cons d0 ds => exact ⟨d0, ds, rfl⟩
have hrlen : (b :: bs).length = t := by
rcases childBounded_len_of_keys (by omega) hR_cb hrk with h | h
· exact absurd h (by simp)
· exact h
have hchildren_len : (((a :: as).drop ((a :: as).length - 1)) ++ (b :: bs)).length =
t + 1 := by
rw [List.length_append, hdrop_len, hrlen]; omega
have hmem_drop : ∀ c ∈ (a :: as).drop ((a :: as).length - 1), c ∈ (a :: as) :=
fun c hc => List.mem_of_mem_drop hc
have hd0_mem : d0 ∈ (a :: as) := hmem_drop d0 (by rw [hdd]; simp)
have hab : heightOf a = heightOf b :=
child_height_bridge hL hR hht (c := a) (d := b) (by simp) (by simp)
have hd0b : heightOf d0 = heightOf b :=
(sameDepth_children_eq_height hL d0 hd0_mem a (by simp)).trans hab
have huniform : ∀ c ∈ ((a :: as).drop ((a :: as).length - 1) ++ (b :: bs)),
heightOf c = heightOf b := by
intro c hc
rw [List.mem_append] at hc
rcases hc with hc | hc
· exact (sameDepth_children_eq_height hL c (hmem_drop c hc) a (by simp)).trans hab
· exact sameDepth_children_eq_height hR c hc b (by simp)
have hsd_all : ∀ c ∈ ((a :: as).drop ((a :: as).length - 1) ++ (b :: bs)),
SameDepth c := by
intro c hc
rw [List.mem_append] at hc
rcases hc with hc | hc
· exact sameDepth_children_sd hL c (hmem_drop c hc)
· exact sameDepth_children_sd hR c hc
have hcons : (a :: as).drop ((a :: as).length - 1) ++ (b :: bs) =
d0 :: (ds ++ (b :: bs)) := by
rw [hdd, List.cons_append]
rw [hcons]
-- heights: every element of the new children list has height `heightOf b`
have huniform_tail : ∀ c ∈ (ds ++ (b :: bs)), heightOf c = heightOf d0 := by
intro c hc
have hb2 : heightOf c = heightOf b :=
huniform c (by rw [hcons]; exact List.mem_cons_of_mem d0 hc)
rw [hb2, ← hd0b]
refine ⟨?_, ?_, ?_⟩
· -- occupancy: t keys, t + 1 children
refine occupancy_false_intro (by rw [hkeys_len]; omega) (by rw [hkeys_len]; omega)
(Or.inr ?_) ?_
· have hcl : (d0 :: (ds ++ (b :: bs))).length = t + 1 := by
rw [← hcons]; exact hchildren_len
rw [hcl]; exact ⟨by omega, by omega⟩
· intro c hc
rw [← hcons] at hc
rw [List.mem_append] at hc
rcases hc with hc | hc
· exact hL_sub c (hmem_drop c hc)
· exact hR_sub c hc
· exact sameDepth_of_uniform (H := heightOf b) (by rw [← hcons]; exact huniform)
(by rw [← hcons]; exact hsd_all)
· rw [heightOf_uniform_children huniform_tail, heightOf_internal_of_sameDepth hR, hd0b]
keysOf membership across rotations
rotateRight reduces on a right sibling with no keys (identity case).
@[simp] lemma rotateRight_nil (lKeys : List Nat) (lCh rCh : List BTree) (sep : Nat) :
rotateRight (node lKeys lCh) sep (node [] rCh) = (node lKeys lCh, sep, node [] rCh) := rfl
Membership across rotateRight. Borrowing from the right sibling neither
creates nor destroys keys: the keys of the two produced nodes plus the new
separator are exactly the keys of the original nodes plus the old separator.
lemma mem_keysOf_rotateRight (l : BTree) (sep : Nat) (r : BTree) (k : Nat) :
k ∈ keysOf (rotateRight l sep r).1 ∨ k = (rotateRight l sep r).2.1 ∨
k ∈ keysOf (rotateRight l sep r).2.2 ↔
k ∈ keysOf l ∨ k = sep ∨ k ∈ keysOf r := by
cases l with
| node lKeys lCh =>
cases r with
| node rKeys rCh =>
cases rKeys with
| nil =>
rw [rotateRight_nil]
| cons rHead rTail =>
have hbridge : k ∈ rCh.flatMap keysOf ↔
k ∈ (rCh.take 1).flatMap keysOf ∨ k ∈ (rCh.drop 1).flatMap keysOf := by
conv_lhs => rw [← List.take_append_drop 1 rCh]
rw [List.flatMap_append, List.mem_append]
rw [rotateRight_cons]
show k ∈ keysOf (node (lKeys ++ [sep]) (lCh ++ rCh.take 1)) ∨ k = rHead ∨
k ∈ keysOf (node rTail (rCh.drop 1)) ↔
k ∈ keysOf (node lKeys lCh) ∨ k = sep ∨ k ∈ keysOf (node (rHead :: rTail) rCh)
simp only [keysOf, List.mem_append, List.mem_cons, List.not_mem_nil, or_false,
List.flatMap_append]
rw [hbridge]
tauto
Membership across rotateLeft. Borrowing from the left sibling neither
creates nor destroys keys: the keys of the two produced nodes plus the new
separator are exactly the keys of the original nodes plus the old separator.
lemma mem_keysOf_rotateLeft (l : BTree) (sep : Nat) (r : BTree) (k : Nat) :
k ∈ keysOf (rotateLeft l sep r).1 ∨ k = (rotateLeft l sep r).2.1 ∨
k ∈ keysOf (rotateLeft l sep r).2.2 ↔
k ∈ keysOf l ∨ k = sep ∨ k ∈ keysOf r := by
cases l with
| node lKeys lCh =>
cases r with
| node rKeys rCh =>
cases lKeys with
| nil =>
rw [rotateLeft_nil]
| cons lHead lTail =>
have hb1 : (k = lHead ∨ k ∈ lTail) ↔ k ∈ (lHead :: lTail).dropLast ∨
k = (lHead :: lTail).getLast (List.cons_ne_nil _ _) := by
have h : k ∈ (lHead :: lTail) ↔ k ∈ (lHead :: lTail).dropLast ∨
k = (lHead :: lTail).getLast (List.cons_ne_nil _ _) := by
conv_lhs => rw [← List.dropLast_append_getLast (List.cons_ne_nil lHead lTail)]
rw [List.mem_append, List.mem_singleton]
rwa [List.mem_cons] at h
have hb2 : k ∈ lCh.flatMap keysOf ↔
k ∈ (lCh.take (lCh.length - 1)).flatMap keysOf ∨
k ∈ (lCh.drop (lCh.length - 1)).flatMap keysOf := by
conv_lhs => rw [← List.take_append_drop (lCh.length - 1) lCh]
rw [List.flatMap_append, List.mem_append]
rw [rotateLeft_cons]
show k ∈ keysOf (node (lHead :: lTail).dropLast (lCh.take (lCh.length - 1))) ∨
k = (lHead :: lTail).getLast (List.cons_ne_nil lHead lTail) ∨
k ∈ keysOf (node (sep :: rKeys) ((lCh.drop (lCh.length - 1)) ++ rCh)) ↔
k ∈ keysOf (node (lHead :: lTail) lCh) ∨ k = sep ∨
k ∈ keysOf (node rKeys rCh)
simp only [keysOf, List.mem_append, List.mem_cons, List.not_mem_nil, or_false,
List.flatMap_append]
rw [hb1, hb2]
tautoHelper functions for the composed delete
Number of keys in a B-tree node.
Remove the first occurrence of x from a list.
def sortedRemove (x : Nat) : List Nat → List Nat
| [] => []
| k :: ks => if k = x then ks else k :: sortedRemove x ks@[simp] lemma sortedRemove_nil (x : Nat) : sortedRemove x [] = [] := rfllemma sortedRemove_cons (x k : Nat) (ks : List Nat) :
sortedRemove x (k :: ks) = if k = x then ks else k :: sortedRemove x ks := rfl
sortedRemove doesn't introduce new elements.
lemma mem_of_sortedRemove {x y : Nat} {ks : List Nat} (hy : y ∈ sortedRemove x ks) : y ∈ ks := by
induction ks with
| nil => simp [sortedRemove] at hy
| cons k ks ih =>
rw [sortedRemove_cons] at hy
split at hy
· subst k; simp [hy]
· simp at hy; rcases hy with (rfl | hy)
· simp
· simp [ih hy]
sortedRemove preserves sortedness.
lemma sortedRemove_sorted (x : Nat) : ∀ {ks : List Nat}, List.Pairwise (· ≤ ·) ks →
List.Pairwise (· ≤ ·) (sortedRemove x ks) := by
intro ks h
induction ks with
| nil => exact h
| cons k ks ih =>
rw [sortedRemove_cons]
split
· exact h.tail
· refine List.Pairwise.cons ?_ (ih h.tail)
obtain ⟨hk, _⟩ := List.pairwise_cons.mp h
intro a ha
exact hk a (mem_of_sortedRemove ha)
sortedRemove length bounds
lemma sortedRemove_length_le (x : Nat) (ks : List Nat) :
(sortedRemove x ks).length ≤ ks.length := by
induction ks with
| nil => simp
| cons k ks ih =>
rw [sortedRemove_cons]; split <;> simp [ih]
lemma sortedRemove_length_ge (x : Nat) (ks : List Nat) :
ks.length - 1 ≤ (sortedRemove x ks).length := by
induction ks with
| nil => simp
| cons k ks ih =>
rw [sortedRemove_cons]; split
· simp
· simp; omega
sortedRemove preserves leaf invariants
lemma sortedRemove_sorted_leaf (x : Nat) (ks : List Nat)
(hs : List.Pairwise (· ≤ ·) ks) :
List.Pairwise (· ≤ ·) (sortedRemove x ks) := by
induction ks with
| nil => exact hs
| cons k ks ih =>
rw [sortedRemove_cons]; split
· exact hs.tail
· refine List.Pairwise.cons ?_ (ih hs.tail)
obtain ⟨hk, _⟩ := List.pairwise_cons.mp hs
intro a ha; exact hk a (mem_of_sortedRemove ha)Composed delete (CLRS B-TREE-DELETE)
Height of mergeNodes (for termination of composedDelete)
The height of a merged node is the maximum of the two component heights.
This holds for all trees, not just well-formed ones, and does not require
SameDepth.
lemma foldl_max_aux (a : Nat) (bs : List Nat) : (bs.foldl max a) = max a (bs.foldl max 0) := by
induction bs generalizing a with
| nil => simp
| cons b bs ih =>
calc
(b :: bs).foldl max a = (bs.foldl max (max a b)) := by simp [List.foldl_cons]
_ = max (max a b) (bs.foldl max 0) := by rw [ih]
_ = max a (max b (bs.foldl max 0)) := by omega
_ = max a ((b :: bs).foldl max 0) := by
rw [List.foldl_cons, show max (0 : Nat) b = b by omega, ih b]
lemma foldl_max_append (l₁ l₂ : List Nat) : ((l₁ ++ l₂).foldl max 0) = max (l₁.foldl max 0) (l₂.foldl max 0) := by
induction l₁ with
| nil => simp
| cons a l₁ ih =>
calc
((a :: (l₁ ++ l₂)).foldl max 0) = ((l₁ ++ l₂).foldl max (max 0 a)) := by simp
_ = max (max 0 a) (((l₁ ++ l₂).foldl max 0)) := by rw [foldl_max_aux]
_ = max (max 0 a) (max (l₁.foldl max 0) (l₂.foldl max 0)) := by rw [ih]
_ = max a (max (l₁.foldl max 0) (l₂.foldl max 0)) := by omega
_ = max ((a :: l₁).foldl max 0) (l₂.foldl max 0) := by
calc
max a (max (l₁.foldl max 0) (l₂.foldl max 0))
= max (max a (l₁.foldl max 0)) (l₂.foldl max 0) := by omega
_ = max ((a :: l₁).foldl max 0) (l₂.foldl max 0) := by
have h : (a :: l₁).foldl max 0 = max a (l₁.foldl max 0) := by
calc
(a :: l₁).foldl max 0 = (l₁.foldl max (max 0 a)) := by simp
_ = (l₁.foldl max a) := by simp
_ = max a (l₁.foldl max 0) := by rw [foldl_max_aux]
rw [h]
lemma heightOf_mergeNodes_eq_max {left right : BTree} {sep : Nat} :
heightOf (mergeNodes left sep right) = max (heightOf left) (heightOf right) := by
cases left with
| node lKeys lCh =>
cases right with
| node rKeys rCh =>
rw [mergeNodes_node]
by_cases hl : lCh = []
· subst hl
by_cases hr : rCh = []
· subst hr; simp [heightOf]
· simp [heightOf, hr]
· by_cases hr : rCh = []
· subst hr; simp [heightOf, hl]
· have hne : lCh ++ rCh ≠ [] := by
intro h
have hnil := (List.append_eq_nil_iff.mp h).1
exact hl hnil
set A := ((lCh.map heightOf).foldl max 0) with hA
set B := ((rCh.map heightOf).foldl max 0) with hB
have hcalc : 1 + max A B = max (1 + A) (1 + B) := by
by_cases h : A ≤ B
· rw [Nat.max_eq_right h, Nat.max_eq_right (by omega : 1 + A ≤ 1 + B)]
· rw [Nat.max_eq_left (by omega : B ≤ A), Nat.max_eq_left (by omega : 1 + B ≤ 1 + A)]
-- Expand heightOf for the three nodes
have hlCh_ht : heightOf (node lKeys lCh) = 1 + A := by
simp [heightOf, hl, hA]
have hrCh_ht : heightOf (node rKeys rCh) = 1 + B := by
simp [heightOf, hr, hB]
have hmerged_ht : heightOf (node (lKeys ++ sep :: rKeys) (lCh ++ rCh)) = 1 + (((lCh ++ rCh).map heightOf).foldl max 0) := by
simp [heightOf, hne]
rw [hmerged_ht, hlCh_ht, hrCh_ht, List.map_append, foldl_max_append, hcalc]
Unconditional height bounds for rotations (termination of composedDelete)
rotateRight repaired-left height bound (unconditional). The new
left node's children are drawn from lCh and rCh.take 1, both
sub-lists of lCh ++ rCh, so its height is at most the maximum of the
two input heights. No invariant hypotheses are needed, which is what makes
the lemma usable in decreasing_by.
lemma heightOf_rotateRight_left_le (l : BTree) (sep : Nat) (r : BTree) :
heightOf (rotateRight l sep r).1 ≤ max (heightOf l) (heightOf r) := by
cases l with
| node lKeys lCh =>
cases r with
| node rKeys rCh =>
cases rKeys with
| nil =>
rw [rotateRight_nil]
exact Nat.le_max_left _ _
| cons rHead rTail =>
rw [rotateRight_cons]
show heightOf (node (lKeys ++ [sep]) (lCh ++ rCh.take 1)) ≤ _
have hsub : lCh ++ rCh.take 1 ⊆ lCh ++ rCh := by
intro c hc
rw [List.mem_append] at hc
rcases hc with hc | hc
· exact List.mem_append_left _ hc
· exact List.mem_append_right _ (List.take_subset 1 rCh hc)
have hle : heightOf (node (lKeys ++ [sep]) (lCh ++ rCh.take 1)) ≤
heightOf (node (lKeys ++ sep :: rHead :: rTail) (lCh ++ rCh)) :=
heightOf_le_of_children_subset hsub
have hmax : heightOf (node (lKeys ++ sep :: rHead :: rTail) (lCh ++ rCh)) =
max (heightOf (node lKeys lCh)) (heightOf (node (rHead :: rTail) rCh)) := by
rw [← mergeNodes_node, heightOf_mergeNodes_eq_max]
exact le_trans hle (le_of_eq hmax)
rotateRight trimmed-right height bound (unconditional). The new
right node's children are rCh.drop 1 ⊆ rCh.
lemma heightOf_rotateRight_right_le (l : BTree) (sep : Nat) (r : BTree) :
heightOf (rotateRight l sep r).2.2 ≤ max (heightOf l) (heightOf r) := by
cases l with
| node lKeys lCh =>
cases r with
| node rKeys rCh =>
cases rKeys with
| nil =>
rw [rotateRight_nil]
exact Nat.le_max_right _ _
| cons rHead rTail =>
rw [rotateRight_cons]
show heightOf (node rTail (rCh.drop 1)) ≤ _
exact le_trans (heightOf_le_of_children_subset (List.drop_subset 1 rCh))
(Nat.le_max_right _ _)
rotateLeft trimmed-left height bound (unconditional). The new left
node's children are lCh.take (lCh.length - 1) ⊆ lCh.
lemma heightOf_rotateLeft_left_le (l : BTree) (sep : Nat) (r : BTree) :
heightOf (rotateLeft l sep r).1 ≤ max (heightOf l) (heightOf r) := by
cases l with
| node lKeys lCh =>
cases r with
| node rKeys rCh =>
cases lKeys with
| nil =>
rw [rotateLeft_nil]
exact Nat.le_max_left _ _
| cons lHead lTail =>
rw [rotateLeft_cons]
show heightOf (node (lHead :: lTail).dropLast (lCh.take (lCh.length - 1))) ≤ _
exact le_trans (heightOf_le_of_children_subset (List.take_subset _ lCh))
(Nat.le_max_left _ _)
rotateLeft repaired-right height bound (unconditional). The new
right node's children are drawn from lCh.drop (lCh.length - 1) and
rCh, both sub-lists of lCh ++ rCh. Mirrors
heightOf_rotateRight_left_le.
lemma heightOf_rotateLeft_right_le (l : BTree) (sep : Nat) (r : BTree) :
heightOf (rotateLeft l sep r).2.2 ≤ max (heightOf l) (heightOf r) := by
cases l with
| node lKeys lCh =>
cases r with
| node rKeys rCh =>
cases lKeys with
| nil =>
rw [rotateLeft_nil]
exact Nat.le_max_right _ _
| cons lHead lTail =>
rw [rotateLeft_cons]
show heightOf (node (sep :: rKeys) (lCh.drop (lCh.length - 1) ++ rCh)) ≤ _
have hsub : lCh.drop (lCh.length - 1) ++ rCh ⊆ lCh ++ rCh := by
intro c hc
rw [List.mem_append] at hc
rcases hc with hc | hc
· exact List.mem_append_left _ (List.drop_subset _ lCh hc)
· exact List.mem_append_right _ hc
have hle : heightOf (node (sep :: rKeys) (lCh.drop (lCh.length - 1) ++ rCh)) ≤
heightOf (node (lHead :: lTail ++ sep :: rKeys) (lCh ++ rCh)) :=
heightOf_le_of_children_subset hsub
have hmax : heightOf (node (lHead :: lTail ++ sep :: rKeys) (lCh ++ rCh)) =
max (heightOf (node (lHead :: lTail) lCh)) (heightOf (node rKeys rCh)) := by
rw [← mergeNodes_node, heightOf_mergeNodes_eq_max]
exact le_trans hle (le_of_eq hmax)
maxKey / minKey: rightmost / leftmost key read
BTree default inhabitant, used by getLast! / head! spine descent.
Bridge from the defaulting getLast! to the hypothesis-carrying getLast.
lemma getLast!_eq_getLast {α : Type*} [Inhabited α] {l : List α} (h : l ≠ []) :
l.getLast! = l.getLast h := by
cases l with
| nil => exact absurd rfl h
| cons a as => rfl
Bridge from the defaulting head! to the hypothesis-carrying head.
lemma head!_eq_head {α : Type*} [Inhabited α] {l : List α} (h : l ≠ []) :
l.head! = l.head h := by
cases l with
| nil => exact absurd rfl h
| cons a as => rfl
lemma getLast!_mem {α : Type*} [Inhabited α] {l : List α} (h : l ≠ []) :
l.getLast! ∈ l := by
rw [getLast!_eq_getLast h]; exact List.getLast_mem h
lemma head!_mem {α : Type*} [Inhabited α] {l : List α} (h : l ≠ []) :
l.head! ∈ l := by
rw [head!_eq_head h]; exact List.head_mem h
lemma getLast!_eq_getElem {α : Type*} [Inhabited α] {l : List α} (h : 0 < l.length) :
l.getLast! = l[l.length - 1] := by
have hne : l ≠ [] := by intro he; rw [he] at h; simp at h
rw [getLast!_eq_getLast hne]; exact List.getLast_eq_getElem hnelemma head!_eq_getElem {α : Type*} [Inhabited α] {l : List α} (h : 0 < l.length) :
l.head! = l[0] := by
cases l with
| nil => simp at h
| cons a as => rfl
In a sorted (≤-pairwise) nonempty list, every element is below the last one.
lemma le_getLast!_of_pairwise {l : List Nat} (hp : l.Pairwise (· ≤ ·)) (hne : 0 < l.length)
{k : Nat} (hk : k ∈ l) : k ≤ l.getLast! := by
rw [getLast!_eq_getElem hne]
obtain ⟨j, hj, rfl⟩ := List.mem_iff_getElem.mp hk
exact pairwise_get_mono hp (by omega) hj (by omega)
In a sorted (≤-pairwise) nonempty list, the first element is below every element.
lemma head!_le_of_pairwise {l : List Nat} (hp : l.Pairwise (· ≤ ·)) (hne : 0 < l.length)
{k : Nat} (hk : k ∈ l) : l.head! ≤ k := by
rw [head!_eq_getElem hne]
obtain ⟨j, hj, rfl⟩ := List.mem_iff_getElem.mp hk
exact pairwise_get_mono hp (Nat.zero_le j) hne hjHereditary key-nonemptiness: every node of the tree has at least one key.
def AllKeysPos : BTree → Prop
| node ks cs => 0 < ks.length ∧ ∀ c ∈ cs, AllKeysPos cRightmost key of a B-tree: the last key of a leaf, else descend the last child.
def maxKey : BTree → Nat
| node ks cs => if _h : cs.isEmpty then ks.getLast! else maxKey (cs.getLast!)
termination_by tr => heightOf tr
decreasing_by
have hne : cs ≠ [] := by
intro he; subst he; simp at _h
exact heightOf_mem_lt (getLast!_mem hne)Leftmost key of a B-tree: the first key of a leaf, else descend the first child.
def minKey : BTree → Nat
| node ks cs => if _h : cs.isEmpty then ks.head! else minKey (cs.head!)
termination_by tr => heightOf tr
decreasing_by
have hne : cs ≠ [] := by
intro he; subst he; simp at _h
exact heightOf_mem_lt (head!_mem hne)@[simp] lemma maxKey_leaf (ks : List Nat) : maxKey (node ks []) = ks.getLast! := by
simp [maxKey]lemma maxKey_internal {ks : List Nat} {cs : List BTree} (h : cs.isEmpty = false) :
maxKey (node ks cs) = maxKey (cs.getLast!) := by
simp [maxKey, h]@[simp] lemma minKey_leaf (ks : List Nat) : minKey (node ks []) = ks.head! := by
simp [minKey]lemma minKey_internal {ks : List Nat} {cs : List BTree} (h : cs.isEmpty = false) :
minKey (node ks cs) = minKey (cs.head!) := by
simp [minKey, h]The rightmost key of a tree with nonempty keys everywhere is a key of the tree.
theorem maxKey_mem (tr : BTree) (hne : AllKeysPos tr) : maxKey tr ∈ keysOf tr := by
let motive (n : Nat) : Prop :=
∀ (tr' : BTree), heightOf tr' = n → AllKeysPos tr' → maxKey tr' ∈ keysOf tr'
have h_ind : ∀ n, (∀ m < n, motive m) → motive n := by
intro n ihn tr' hn hne'
cases tr' with
| node ks cs =>
unfold AllKeysPos at hne'
obtain ⟨hks, hcs⟩ := hne'
by_cases hce : cs.isEmpty
· have hcs' : cs = [] := List.isEmpty_iff.mp hce
subst hcs'
rw [maxKey_leaf]
have hks' : ks ≠ [] := by intro he; rw [he] at hks; simp at hks
simp only [keysOf, List.flatMap_nil, List.append_nil]
exact getLast!_mem hks'
· have hne'' : cs ≠ [] := by intro he; subst he; simp at hce
have hmem : cs.getLast! ∈ cs := getLast!_mem hne''
have hfalse : cs.isEmpty = false := by simpa using hce
rw [maxKey_internal hfalse]
have hlt : heightOf (cs.getLast!) < n := by
calc heightOf (cs.getLast!) < heightOf (node ks cs) := heightOf_mem_lt hmem
_ = n := hn
have hrec := ihn _ hlt _ rfl (hcs _ hmem)
simp only [keysOf, List.mem_append]
exact Or.inr (List.mem_flatMap.mpr ⟨_, hmem, hrec⟩)
exact (Nat.strongRecOn (motive := motive) (heightOf tr) h_ind) tr rfl hneThe leftmost key of a tree with nonempty keys everywhere is a key of the tree.
theorem minKey_mem (tr : BTree) (hne : AllKeysPos tr) : minKey tr ∈ keysOf tr := by
let motive (n : Nat) : Prop :=
∀ (tr' : BTree), heightOf tr' = n → AllKeysPos tr' → minKey tr' ∈ keysOf tr'
have h_ind : ∀ n, (∀ m < n, motive m) → motive n := by
intro n ihn tr' hn hne'
cases tr' with
| node ks cs =>
unfold AllKeysPos at hne'
obtain ⟨hks, hcs⟩ := hne'
by_cases hce : cs.isEmpty
· have hcs' : cs = [] := List.isEmpty_iff.mp hce
subst hcs'
rw [minKey_leaf]
have hks' : ks ≠ [] := by intro he; rw [he] at hks; simp at hks
simp only [keysOf, List.flatMap_nil, List.append_nil]
exact head!_mem hks'
· have hne'' : cs ≠ [] := by intro he; subst he; simp at hce
have hmem : cs.head! ∈ cs := head!_mem hne''
have hfalse : cs.isEmpty = false := by simpa using hce
rw [minKey_internal hfalse]
have hlt : heightOf (cs.head!) < n := by
calc heightOf (cs.head!) < heightOf (node ks cs) := heightOf_mem_lt hmem
_ = n := hn
have hrec := ihn _ hlt _ rfl (hcs _ hmem)
simp only [keysOf, List.mem_append]
exact Or.inr (List.mem_flatMap.mpr ⟨_, hmem, hrec⟩)
exact (Nat.strongRecOn (motive := motive) (heightOf tr) h_ind) tr rfl hneEvery key of a sorted, child-bounded tree with nonempty keys everywhere is at most the rightmost key.
theorem maxKey_ge (tr : BTree) (hs : Sorted tr) (hcb : ChildBounded tr)
(hne : AllKeysPos tr) : ∀ k ∈ keysOf tr, k ≤ maxKey tr := by
let motive (n : Nat) : Prop :=
∀ (tr' : BTree), heightOf tr' = n → Sorted tr' → ChildBounded tr' → AllKeysPos tr' →
∀ k ∈ keysOf tr', k ≤ maxKey tr'
have h_ind : ∀ n, (∀ m < n, motive m) → motive n := by
intro n ihn tr' hn hs hcb hne'
cases tr' with
| node ks cs =>
unfold Sorted at hs
unfold ChildBounded at hcb
unfold AllKeysPos at hne'
obtain ⟨hpw, hsC⟩ := hs
obtain ⟨hrel, hbound, hcbC⟩ := hcb
obtain ⟨hks, hneC⟩ := hne'
intro k hk
by_cases hce : cs.isEmpty
· have hcs' : cs = [] := List.isEmpty_iff.mp hce
subst hcs'
rw [maxKey_leaf]
simp only [keysOf, List.flatMap_nil, List.append_nil] at hk
exact le_getLast!_of_pairwise hpw hks hk
· have hne'' : cs ≠ [] := by intro he; subst he; simp at hce
have hfalse : cs.isEmpty = false := by simpa using hce
rw [maxKey_internal hfalse]
have hlen : cs.length = ks.length + 1 := by
rcases hrel with hemp | hlen
· exact absurd (List.isEmpty_iff.mp hemp) hne''
· exact hlen
set len := ks.length with hlen_eq
have hcs_pos : 0 < cs.length := by omega
have hin : len < cs.length := by omega
have hlast_mem : cs.getLast! ∈ cs := getLast!_mem hne''
-- `cs.getLast!` is the child at index `len = cs.length - 1`.
have hlast_eq : cs.getLast! = cs[len]'hin := by
rw [getLast!_eq_getElem hcs_pos]
congr 1
omega
-- The last separator key is a lower bound for the last child's keys.
have hlast_key : ks.getLast! ≤ maxKey (cs.getLast!) := by
have hkn1 : len - 1 < ks.length := by omega
have hlow := (hbound len hin).1
rw [List.getElem?_eq_getElem hkn1] at hlow
rcases hlow with h0 | hb
· omega
· have hb' : ∀ k' ∈ keysOf (cs[len]'hin), ks[len - 1]'hkn1 ≤ k' := hb
rw [← hlast_eq] at hb'
have hmemmax : maxKey (cs.getLast!) ∈ keysOf (cs.getLast!) :=
maxKey_mem _ (hneC _ hlast_mem)
have hle := hb' _ hmemmax
have hgoal : ks.getLast! = ks[len - 1]'hkn1 := by
rw [getLast!_eq_getElem hks]
rw [hgoal]
exact hle
simp only [keysOf, List.mem_append] at hk
rcases hk with hkk | hkc
· exact le_trans (le_getLast!_of_pairwise hpw hks hkk) hlast_key
· obtain ⟨c, hc, hkc'⟩ := List.mem_flatMap.mp hkc
obtain ⟨j, hj, rfl⟩ := List.mem_iff_getElem.mp hc
by_cases hjn : j = len
· -- Key in the last child: induction hypothesis.
subst hjn
rw [hlast_eq]
have hlt : heightOf (cs[len]'hj) < n := by
calc heightOf (cs[len]'hj) < heightOf (node ks cs) := heightOf_mem_lt hc
_ = n := hn
exact ihn _ hlt _ rfl (hsC _ hc) (hcbC _ hc) (hneC _ hc) k hkc'
· -- Key in an earlier child: bounded above by `ks[j] ≤ ks.getLast!`.
have hjk : j < ks.length := by omega
have hup := (hbound j hj).2
rw [List.getElem?_eq_getElem hjk] at hup
have hup' : ∀ k' ∈ keysOf (cs[j]'hj), k' ≤ ks[j]'hjk := hup
have hk_le := hup' k hkc'
have hkj_mem : ks[j]'hjk ∈ ks := List.getElem_mem hjk
exact le_trans (le_trans hk_le (le_getLast!_of_pairwise hpw hks hkj_mem)) hlast_key
exact (Nat.strongRecOn (motive := motive) (heightOf tr) h_ind) tr rfl hs hcb hneEvery key of a sorted, child-bounded tree with nonempty keys everywhere is at least the leftmost key.
theorem minKey_le (tr : BTree) (hs : Sorted tr) (hcb : ChildBounded tr)
(hne : AllKeysPos tr) : ∀ k ∈ keysOf tr, minKey tr ≤ k := by
let motive (n : Nat) : Prop :=
∀ (tr' : BTree), heightOf tr' = n → Sorted tr' → ChildBounded tr' → AllKeysPos tr' →
∀ k ∈ keysOf tr', minKey tr' ≤ k
have h_ind : ∀ n, (∀ m < n, motive m) → motive n := by
intro n ihn tr' hn hs hcb hne'
cases tr' with
| node ks cs =>
unfold Sorted at hs
unfold ChildBounded at hcb
unfold AllKeysPos at hne'
obtain ⟨hpw, hsC⟩ := hs
obtain ⟨hrel, hbound, hcbC⟩ := hcb
obtain ⟨hks, hneC⟩ := hne'
intro k hk
by_cases hce : cs.isEmpty
· have hcs' : cs = [] := List.isEmpty_iff.mp hce
subst hcs'
rw [minKey_leaf]
simp only [keysOf, List.flatMap_nil, List.append_nil] at hk
exact head!_le_of_pairwise hpw hks hk
· have hne'' : cs ≠ [] := by intro he; subst he; simp at hce
have hfalse : cs.isEmpty = false := by simpa using hce
rw [minKey_internal hfalse]
have hlen : cs.length = ks.length + 1 := by
rcases hrel with hemp | hlen
· exact absurd (List.isEmpty_iff.mp hemp) hne''
· exact hlen
set len := ks.length with hlen_eq
have hcs_pos : 0 < cs.length := by omega
have hhead_mem : cs.head! ∈ cs := head!_mem hne''
-- `cs.head!` is the child at index `0`.
have hhead_eq : cs.head! = cs[0]'hcs_pos := head!_eq_getElem hcs_pos
-- The first key is an upper bound for the first child's keys.
have hfirst_key : minKey (cs.head!) ≤ ks.head! := by
have hup := (hbound 0 hcs_pos).2
rw [List.getElem?_eq_getElem hks] at hup
have hup' : ∀ k' ∈ keysOf (cs[0]'hcs_pos), k' ≤ ks[0]'hks := hup
rw [← hhead_eq] at hup'
have hmemmin : minKey (cs.head!) ∈ keysOf (cs.head!) :=
minKey_mem _ (hneC _ hhead_mem)
have hle := hup' _ hmemmin
rw [head!_eq_getElem hks]
exact hle
simp only [keysOf, List.mem_append] at hk
rcases hk with hkk | hkc
· exact le_trans hfirst_key (head!_le_of_pairwise hpw hks hkk)
· obtain ⟨c, hc, hkc'⟩ := List.mem_flatMap.mp hkc
obtain ⟨j, hj, rfl⟩ := List.mem_iff_getElem.mp hc
by_cases hj0 : j = 0
· -- Key in the first child: induction hypothesis.
subst hj0
rw [hhead_eq]
have hlt : heightOf (cs[0]'hj) < n := by
calc heightOf (cs[0]'hj) < heightOf (node ks cs) := heightOf_mem_lt hc
_ = n := hn
exact ihn _ hlt _ rfl (hsC _ hc) (hcbC _ hc) (hneC _ hc) k hkc'
· -- Key in a later child: bounded below by `ks.head! ≤ ks[j-1] ≤ k`.
have hjm1 : j - 1 < ks.length := by omega
have hlow := (hbound j hj).1
rw [List.getElem?_eq_getElem hjm1] at hlow
rcases hlow with h0' | hb
· omega
· have hb' : ∀ k' ∈ keysOf (cs[j]'hj), ks[j - 1]'hjm1 ≤ k' := hb
have hk_ge := hb' k hkc'
have hjm1_mem : ks[j - 1]'hjm1 ∈ ks := List.getElem_mem hjm1
exact le_trans (le_trans hfirst_key (head!_le_of_pairwise hpw hks hjm1_mem)) hk_ge
exact (Nat.strongRecOn (motive := motive) (heightOf tr) h_ind) tr rfl hs hcb hne
AllKeysPos from Occupancy, and preservation across merge/rotations
Occupancy implies hereditary key-nonemptiness. Any tree satisfying
Occupancy whose root has at least one key has at least one key in every
node: non-root nodes carry at least t - 1 ≥ 1 keys. The root
nonemptiness hypothesis is needed because Occupancy allows the empty
root node [] []. Proved by strong induction on height (a BTree
cannot use induction directly because of the nested list recursion).
theorem allKeysPos_of_occupancy (t : Nat) (ht : 2 ≤ t) (tr : BTree) (b : Bool)
(hocc : Occupancy t b tr) (hne : 0 < numKeys tr) : AllKeysPos tr := by
let motive (n : Nat) : Prop := ∀ (tr' : BTree), heightOf tr' = n →
∀ (b' : Bool), Occupancy t b' tr' → 0 < numKeys tr' → AllKeysPos tr'
have h_ind : ∀ n, (∀ m < n, motive m) → motive n := by
intro n ihn tr' hn b' hocc' hne'
cases tr' with
| node ks cs =>
unfold AllKeysPos
refine ⟨hne', ?_⟩
intro c hc
have hocc_c : Occupancy t false c := by
unfold Occupancy at hocc'; exact hocc'.2.2.2 c hc
cases c with
| node cks ccs =>
have hne_c : 0 < numKeys (node cks ccs) := by
unfold Occupancy at hocc_c
obtain ⟨hlo_c, -, -, -⟩ := hocc_c
have hlo : t - 1 ≤ cks.length := hlo_c
show 0 < cks.length
omega
have hlt : heightOf (node cks ccs) < n :=
calc heightOf (node cks ccs) < heightOf (node ks cs) := heightOf_mem_lt hc
_ = n := hn
exact ihn _ hlt _ rfl false hocc_c hne_c
exact (Nat.strongRecOn (motive := motive) (heightOf tr) h_ind) tr rfl b hocc hne
Merge preserves hereditary key-nonemptiness. The merged key list
lKeys ++ sep :: rKeys is always nonempty, and children are inherited
from the two inputs.
lemma allKeysPos_mergeNodes {l r : BTree} {sep : Nat}
(hl : AllKeysPos l) (hr : AllKeysPos r) : AllKeysPos (mergeNodes l sep r) := by
cases l with
| node lKeys lCh =>
cases r with
| node rKeys rCh =>
rw [mergeNodes_node]
show AllKeysPos (node (lKeys ++ sep :: rKeys) (lCh ++ rCh))
unfold AllKeysPos at hl hr ⊢
obtain ⟨hlk, hlc⟩ := hl
obtain ⟨hrk, hrc⟩ := hr
refine ⟨?_, ?_⟩
· simp only [List.length_append, List.length_cons]; omega
· intro c hc
rw [List.mem_append] at hc
rcases hc with hc | hc
· exact hlc c hc
· exact hrc c hc
rotateRight repaired-left node preserves AllKeysPos. The
new key list lKeys ++ [sep] is always nonempty and the children come
from the two inputs.
lemma allKeysPos_rotateRight_left (t : Nat) (ht : 2 ≤ t) (l : BTree) (sep : Nat) (r : BTree)
(_hrlen : t ≤ numKeys r) (hl : AllKeysPos l) (hr : AllKeysPos r) :
AllKeysPos (rotateRight l sep r).1 := by
cases l with
| node lKeys lCh =>
cases r with
| node rKeys rCh =>
cases rKeys with
| nil => rw [rotateRight_nil]; exact hl
| cons rHead rTail =>
rw [rotateRight_cons]
show AllKeysPos (node (lKeys ++ [sep]) (lCh ++ rCh.take 1))
unfold AllKeysPos at hl hr ⊢
obtain ⟨hlk, hlc⟩ := hl
obtain ⟨hrk, hrc⟩ := hr
refine ⟨?_, ?_⟩
· simp only [List.length_append, List.length_cons, List.length_nil]; omega
· intro c hc
rw [List.mem_append] at hc
rcases hc with hc | hc
· exact hlc c hc
· exact hrc c (List.take_subset 1 rCh hc)
rotateRight trimmed-right node preserves AllKeysPos. The
trimmed key list rTail is nonempty because the lender had ≥ t
keys (so ≥ 2); the children are a sub-list of the original right children.
lemma allKeysPos_rotateRight_right (t : Nat) (ht : 2 ≤ t) (l : BTree) (sep : Nat) (r : BTree)
(hrlen : t ≤ numKeys r) (hl : AllKeysPos l) (hr : AllKeysPos r) :
AllKeysPos (rotateRight l sep r).2.2 := by
cases l with
| node lKeys lCh =>
cases r with
| node rKeys rCh =>
cases rKeys with
| nil => change t ≤ 0 at hrlen; omega
| cons rHead rTail =>
rw [rotateRight_cons]
show AllKeysPos (node rTail (rCh.drop 1))
unfold AllKeysPos at hr ⊢
obtain ⟨hrk, hrc⟩ := hr
refine ⟨?_, ?_⟩
· have h1 : t ≤ rTail.length + 1 := hrlen
omega
· intro c hc
exact hrc c (List.drop_subset 1 rCh hc)
rotateLeft trimmed-left node preserves AllKeysPos. The
trimmed key list lKeys.dropLast is nonempty because the lender had ≥
t keys (so ≥ 2).
lemma allKeysPos_rotateLeft_left (t : Nat) (ht : 2 ≤ t) (l : BTree) (sep : Nat) (r : BTree)
(hllen : t ≤ numKeys l) (hl : AllKeysPos l) (hr : AllKeysPos r) :
AllKeysPos (rotateLeft l sep r).1 := by
cases l with
| node lKeys lCh =>
cases r with
| node rKeys rCh =>
cases lKeys with
| nil => change t ≤ 0 at hllen; omega
| cons lHead lTail =>
rw [rotateLeft_cons]
show AllKeysPos (node (lHead :: lTail).dropLast (lCh.take (lCh.length - 1)))
unfold AllKeysPos at hl ⊢
obtain ⟨hlk, hlc⟩ := hl
refine ⟨?_, ?_⟩
· have h1 : t ≤ lTail.length + 1 := hllen
rw [List.length_dropLast, List.length_cons]
omega
· intro c hc
exact hlc c (List.take_subset _ lCh hc)
rotateLeft repaired-right node preserves AllKeysPos. The
new key list sep :: rKeys is always nonempty and the children come from
the two inputs.
lemma allKeysPos_rotateLeft_right (t : Nat) (ht : 2 ≤ t) (l : BTree) (sep : Nat) (r : BTree)
(_hllen : t ≤ numKeys l) (hl : AllKeysPos l) (hr : AllKeysPos r) :
AllKeysPos (rotateLeft l sep r).2.2 := by
cases l with
| node lKeys lCh =>
cases r with
| node rKeys rCh =>
cases lKeys with
| nil => rw [rotateLeft_nil]; exact hr
| cons lHead lTail =>
rw [rotateLeft_cons]
show AllKeysPos (node (sep :: rKeys) (lCh.drop (lCh.length - 1) ++ rCh))
unfold AllKeysPos at hl hr ⊢
obtain ⟨hlk, hlc⟩ := hl
obtain ⟨hrk, hrc⟩ := hr
refine ⟨?_, ?_⟩
· simp only [List.length_cons]; omega
· intro c hc
rw [List.mem_append] at hc
rcases hc with hc | hc
· exact hlc c (List.drop_subset _ lCh hc)
· exact hrc c hc
Composed B-tree deletion (CLRS B-TREE-DELETE with pre-emptive repair).
Semantic contract:
-
Leaf:
node (sortedRemove x ks) []— removexfrom the key list. -
Case 1 (
x = ks[ki]hits a separator,ki = findChild ks x - 1):-
1a left child has ≥
tkeys: replace the separator bym := maxKey leftChildand recursively deletemfrom the left child. -
1b else the right child has ≥
tkeys: symmetric, withm := minKey rightChilddeleted from the right child. -
1c else both children are minimal: merge them around
xand recurse into the merged node (as before).
-
-
Case 2 (descend into child
j, three descent sites:k ≠ x,ks[ki]? = none, andfindChild ks x = 0): guarded descent —-
child has ≥
tkeys: descend directly (as before); -
else the left sibling
cs[j-1]exists (j > 0) and has ≥tkeys:rotateLeftborrows across separatorks[j-1], descend into the repaired child; -
else the right sibling
cs[j+1]exists and has ≥tkeys:rotateRightborrows across separatorks[j], descend into the repaired child; -
else merge with an available sibling (
j > 0: left,j = 0: right) and descend into the merged node. Degenerate branches (sibling or separator lookup failure) fall back to the unguarded direct descent, keeping the function total on arbitrary inputs.
-
-
The
i = 0descent site has no left sibling, so its guard sequence is only "direct → borrow right → merge right".
Termination is by heightOf: every recursive call targets either a child
(heightOf_mem_lt) or a rotation/merge result whose height is at most the
maximum of two child heights (heightOf_rotateLeft_right_le,
heightOf_rotateRight_left_le, heightOf_mergeNodes_eq_max),
strictly below the parent's height.
def composedDelete (t : Nat) (x : Nat) : BTree → BTree
| node ks cs =>
if cs.isEmpty then
node (sortedRemove x ks) []
else
let i := findChild ks x
if hiPos : 0 < i then
let ki := i - 1
match hk : ks[ki]? with
| some k =>
if hkeq : k = x then
match hcl : cs[ki]? with
| some leftChild =>
match hcr : cs[ki + 1]? with
| some rightChild =>
if hla : t ≤ numKeys leftChild then
-- Case 1a: predecessor replaces the separator
node (ks.set ki (maxKey leftChild))
(cs.set ki (composedDelete t (maxKey leftChild) leftChild))
else if hlb : t ≤ numKeys rightChild then
-- Case 1b: successor replaces the separator
node (ks.set ki (minKey rightChild))
(cs.set (ki + 1) (composedDelete t (minKey rightChild) rightChild))
else
-- Case 1c: both children minimal, merge and recurse
let merged := mergeNodes leftChild k rightChild
let newMerged := composedDelete t x merged
node (ks.take ki ++ ks.drop (ki + 1)) ((cs.take ki) ++ [newMerged] ++ (cs.drop (ki + 2)))
| none => node (sortedRemove x ks) []
| none => node (sortedRemove x ks) []
else
-- Case 2 descent at j = i (separator key not equal to x)
match hc : cs[i]? with
| some child =>
if hcg : t ≤ numKeys child then
node ks (cs.set i (composedDelete t x child))
else
match hls : cs[i - 1]? with
| some leftSib =>
if hlg : t ≤ numKeys leftSib then
match hsep : ks[i - 1]? with
| some sep =>
node (ks.set (i - 1) (rotateLeft leftSib sep child).2.1)
((cs.set (i - 1) (rotateLeft leftSib sep child).1).set i
(composedDelete t x (rotateLeft leftSib sep child).2.2))
| none => node ks (cs.set i (composedDelete t x child))
else
match hrs : cs[i + 1]? with
| some rightSib =>
if hrg : t ≤ numKeys rightSib then
match hsep : ks[i]? with
| some sep =>
node (ks.set i (rotateRight child sep rightSib).2.1)
((cs.set i (composedDelete t x (rotateRight child sep rightSib).1)).set
(i + 1) (rotateRight child sep rightSib).2.2)
| none => node ks (cs.set i (composedDelete t x child))
else
match hsep : ks[i - 1]? with
| some sep =>
node (ks.take (i - 1) ++ ks.drop i)
(cs.take (i - 1) ++
[composedDelete t x (mergeNodes leftSib sep child)] ++
cs.drop (i + 1))
| none => node ks (cs.set i (composedDelete t x child))
| none =>
match hsep : ks[i - 1]? with
| some sep =>
node (ks.take (i - 1) ++ ks.drop i)
(cs.take (i - 1) ++
[composedDelete t x (mergeNodes leftSib sep child)] ++
cs.drop (i + 1))
| none => node ks (cs.set i (composedDelete t x child))
| none => node ks (cs.set i (composedDelete t x child))
| none => node ks cs
| none =>
-- Case 2 descent at j = i (separator lookup failed)
match hc : cs[i]? with
| some child =>
if hcg : t ≤ numKeys child then
node ks (cs.set i (composedDelete t x child))
else
match hls : cs[i - 1]? with
| some leftSib =>
if hlg : t ≤ numKeys leftSib then
match hsep : ks[i - 1]? with
| some sep =>
node (ks.set (i - 1) (rotateLeft leftSib sep child).2.1)
((cs.set (i - 1) (rotateLeft leftSib sep child).1).set i
(composedDelete t x (rotateLeft leftSib sep child).2.2))
| none => node ks (cs.set i (composedDelete t x child))
else
match hrs : cs[i + 1]? with
| some rightSib =>
if hrg : t ≤ numKeys rightSib then
match hsep : ks[i]? with
| some sep =>
node (ks.set i (rotateRight child sep rightSib).2.1)
((cs.set i (composedDelete t x (rotateRight child sep rightSib).1)).set
(i + 1) (rotateRight child sep rightSib).2.2)
| none => node ks (cs.set i (composedDelete t x child))
else
match hsep : ks[i - 1]? with
| some sep =>
node (ks.take (i - 1) ++ ks.drop i)
(cs.take (i - 1) ++
[composedDelete t x (mergeNodes leftSib sep child)] ++
cs.drop (i + 1))
| none => node ks (cs.set i (composedDelete t x child))
| none =>
match hsep : ks[i - 1]? with
| some sep =>
node (ks.take (i - 1) ++ ks.drop i)
(cs.take (i - 1) ++
[composedDelete t x (mergeNodes leftSib sep child)] ++
cs.drop (i + 1))
| none => node ks (cs.set i (composedDelete t x child))
| none => node ks (cs.set i (composedDelete t x child))
| none => node ks cs
else
-- Case 2 descent at j = 0: no left sibling, right-only guard sequence
match hc : cs[0]? with
| some child =>
if hcg : t ≤ numKeys child then
node ks (cs.set 0 (composedDelete t x child))
else
match hrs : cs[1]? with
| some rightSib =>
if hrg : t ≤ numKeys rightSib then
match hsep : ks[0]? with
| some sep =>
node (ks.set 0 (rotateRight child sep rightSib).2.1)
((cs.set 0 (composedDelete t x (rotateRight child sep rightSib).1)).set 1
(rotateRight child sep rightSib).2.2)
| none => node ks (cs.set 0 (composedDelete t x child))
else
match hsep : ks[0]? with
| some sep =>
node (ks.drop 1)
([composedDelete t x (mergeNodes child sep rightSib)] ++ cs.drop 2)
| none => node ks (cs.set 0 (composedDelete t x child))
| none => node ks (cs.set 0 (composedDelete t x child))
| none => node ks cs
termination_by tr => heightOf tr
decreasing_by
· -- Case 1a: recurse into the left child
exact heightOf_mem_lt (List.mem_iff_getElem?.mpr ⟨ki, hcl⟩)
· -- Case 1b: recurse into the right child
exact heightOf_mem_lt (List.mem_iff_getElem?.mpr ⟨ki + 1, hcr⟩)
· -- Case 1c merge: the merged node has the maximum of the two heights
rw [heightOf_mergeNodes_eq_max]
have ha : heightOf leftChild < heightOf (node ks cs) :=
heightOf_mem_lt (List.mem_iff_getElem?.mpr ⟨ki, hcl⟩)
have hb : heightOf rightChild < heightOf (node ks cs) :=
heightOf_mem_lt (List.mem_iff_getElem?.mpr ⟨ki + 1, hcr⟩)
omega
all_goals
first
-- Merge branches: the merged node has the maximum of the two heights
| (rw [heightOf_mergeNodes_eq_max]
first
| (have ha : heightOf leftSib < heightOf (node ks cs) :=
heightOf_mem_lt (List.mem_iff_getElem?.mpr ⟨_, hls⟩)
have hb : heightOf child < heightOf (node ks cs) :=
heightOf_mem_lt (List.mem_iff_getElem?.mpr ⟨_, hc⟩)
omega)
| (have ha : heightOf child < heightOf (node ks cs) :=
heightOf_mem_lt (List.mem_iff_getElem?.mpr ⟨_, hc⟩)
have hb : heightOf rightSib < heightOf (node ks cs) :=
heightOf_mem_lt (List.mem_iff_getElem?.mpr ⟨_, hrs⟩)
omega))
-- Direct descents and degenerate fallbacks: recurse into a child of `cs`
| exact heightOf_mem_lt (List.mem_iff_getElem?.mpr ⟨_, hc⟩)
-- Borrow-left: the repaired child is bounded by both sibling heights
| (have hle := heightOf_rotateLeft_right_le leftSib sep child
have ha : heightOf leftSib < heightOf (node ks cs) :=
heightOf_mem_lt (List.mem_iff_getElem?.mpr ⟨_, hls⟩)
have hb : heightOf child < heightOf (node ks cs) :=
heightOf_mem_lt (List.mem_iff_getElem?.mpr ⟨_, hc⟩)
omega)
-- Borrow-right: the repaired child is bounded by both sibling heights
| (have hle := heightOf_rotateRight_left_le child sep rightSib
have ha : heightOf child < heightOf (node ks cs) :=
heightOf_mem_lt (List.mem_iff_getElem?.mpr ⟨_, hc⟩)
have hb : heightOf rightSib < heightOf (node ks cs) :=
heightOf_mem_lt (List.mem_iff_getElem?.mpr ⟨_, hrs⟩)
omega)end BTreeend Chapter18end CLRSDefinitions and proofs
CLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.ChildBounded
B-tree deletion: child-bound projection
This submodule retains the public composedDelete_childBounded name as
a small projection from the bundled raw-deletion preservation theorem.
namespace CLRSnamespace Chapter18namespace BTreeRaw deletion preserves recursive child key ranges for a structurally well-formed input node.
lemma composedDelete_childBounded
(t x : Nat) (ht : 2 ≤ t) (tr : BTree) {isRoot : Bool}
(hinv : NodeWF t isRoot tr) :
ChildBounded (composedDelete t x tr) := by
exact
(composedDelete_rootResult t x ht (hinv.asRoot ht)).2.1.2.1end BTreeend Chapter18end CLRSCLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.ComposedPreservation
Complete structural preservation for composed B-tree deletion
The branch packets for leaf deletion, separator replacement, sibling
rotation, and sibling merge are assembled here into one induction over
composedDelete. The bundled result simultaneously records key
containment, the root-sensitive structural postcondition, and raw height
preservation.
namespace CLRS.Chapter18.BTree
Raw composed deletion preserves the complete invariant packet under the CLRS
descent-readiness guard. Root calls may return the one-child empty-root
transient described by RootDeleteResult; non-root calls return an
ordinary NodeWF packet.
theorem composedDelete_packet
(t : Nat) (ht : 2 ≤ t) (x : Nat) (tr : BTree) :
∀ b, NodeWF t b tr → DeleteReady t b tr →
KeysSubset (composedDelete t x tr) tr ∧
RawDeleteResult t b (composedDelete t x tr) ∧
heightOf (composedDelete t x tr) = heightOf tr := by
induction x, tr using composedDelete.induct (t := t) <;>
intro b hparent hready
case case1 =>
rename_i x ks cs hleaf
have hcs : cs = [] := List.isEmpty_iff.mp hleaf
subst cs
simpa [composedDelete] using
(deleteLeaf_packet (x := x) hparent hready)
case case2 =>
rename_i ks cs hnonempty sep left right hleftReady i hpos ki hsep hleft hright ih
simp only [i] at hpos
simp only [ki, i] at hsep hleft hright
have hleftMem : left ∈ cs :=
List.mem_iff_getElem?.mpr ⟨findChild ks sep - 1, hleft⟩
have hleftWF : NodeWF t false left :=
hparent.child hleftMem
have hleftReady' : DeleteReady t false left := by
simpa [DeleteReady] using hleftReady
have hrec := ih false hleftWF hleftReady'
have hrecWF :
NodeWF t false (composedDelete t (maxKey left) left) := by
simpa [RawDeleteResult] using hrec.2.1
have hpacket :=
replacePredecessor_packet ht hparent hsep hleft hrecWF
hrec.2.2 hrec.1
have hraw :=
rawDeleteResult_of_nodeWF hpacket.1
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t sep (node ks cs) =
node (ks.set (findChild ks sep - 1) (maxKey left))
(cs.set (findChild ks sep - 1)
(composedDelete t (maxKey left) left)) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
rw [hsep]
rw [hleft, hright]
simp [hleftReady]
rw [hdeleteEq]
exact And.intro hpacket.2.2 (And.intro hraw hpacket.2.1)
case case3 =>
rename_i ks cs hnonempty sep left right hleftNotReady hrightReady
i hpos ki hsep hleft hright ih
simp only [i] at hpos
simp only [ki, i] at hsep hleft hright
have hrightMem : right ∈ cs :=
List.mem_iff_getElem?.mpr ⟨findChild ks sep - 1 + 1, hright⟩
have hrightWF : NodeWF t false right :=
hparent.child hrightMem
have hrightReady' : DeleteReady t false right := by
simpa [DeleteReady] using hrightReady
have hrec := ih false hrightWF hrightReady'
have hrecWF :
NodeWF t false (composedDelete t (minKey right) right) := by
simpa [RawDeleteResult] using hrec.2.1
have hpacket :=
replaceSuccessor_packet ht hparent hsep hright hrecWF
hrec.2.2 hrec.1
have hraw :=
rawDeleteResult_of_nodeWF hpacket.1
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t sep (node ks cs) =
node (ks.set (findChild ks sep - 1) (minKey right))
(cs.set (findChild ks sep - 1 + 1)
(composedDelete t (minKey right) right)) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
rw [hsep]
rw [hleft, hright]
simp [hleftNotReady, hrightReady]
rw [hdeleteEq]
exact And.intro hpacket.2.2 (And.intro hraw hpacket.2.1)
case case4 =>
rename_i ks cs hnonempty sep left right hleftNotReady hrightNotReady
merged i hpos ki hsep hleft hright ih
simp only [i] at hpos
simp only [ki, i] at hsep hleft hright
obtain ⟨hleftWF, hrightWF, hsiblings, hleftLe, hrightGe⟩ :=
hparent.adjacent_children hsep hleft hright
have hleftMin : numKeys left = t - 1 :=
numKeys_eq_t_sub_one_of_not_ready hleftWF.occupancy hleftNotReady
have hrightMin : numKeys right = t - 1 :=
numKeys_eq_t_sub_one_of_not_ready hrightWF.occupancy hrightNotReady
have hmerged :=
mergeNodes_nodeWF ht hleftWF hrightWF hleftMin hrightMin
hsiblings hleftLe hrightGe
have hmergedWF : NodeWF t false merged := by
simpa [merged] using hmerged.1
have hmergedReady : DeleteReady t false merged := by
simpa [merged] using
(mergeNodes_deleteReady ht (right := right) (sep := sep) hleftMin)
have hrec := ih false hmergedWF hmergedReady
have hrecWF :
NodeWF t false (composedDelete t sep merged) := by
simpa [RawDeleteResult] using hrec.2.1
have hpacket :=
spliceMerged_packet hparent hready hsep hleft hright hrecWF
(by simpa [merged] using hrec.2.2) (by simpa [merged] using hrec.1)
have hraw :
RawDeleteResult t b
(node
(ks.take (findChild ks sep - 1) ++
ks.drop (findChild ks sep - 1 + 1))
(cs.take (findChild ks sep - 1) ++
[composedDelete t sep merged] ++
cs.drop (findChild ks sep - 1 + 2))) := by
cases b <;> simpa [RawDeleteResult] using hpacket.1
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t sep (node ks cs) =
node
(ks.take (findChild ks sep - 1) ++
ks.drop (findChild ks sep - 1 + 1))
(cs.take (findChild ks sep - 1) ++
[composedDelete t sep merged] ++
cs.drop (findChild ks sep - 1 + 2)) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
rw [hsep]
rw [hleft, hright]
simp [hleftNotReady, hrightNotReady, merged]
rw [hdeleteEq]
exact And.intro hpacket.2.2 (And.intro hraw hpacket.2.1)
case case7 =>
rename_i x ks cs hnonempty i hpos ki oldSep hsep hne child hchild
hchildReady ih
simp only [i] at hpos
simp only [ki, i] at hsep
simp only [i] at hchild
have hchildMem : child ∈ cs :=
List.mem_iff_getElem?.mpr ⟨findChild ks x, hchild⟩
have hchildWF : NodeWF t false child :=
hparent.child hchildMem
have hchildReady' : DeleteReady t false child := by
simpa [DeleteReady] using hchildReady
have hrec := ih false hchildWF hchildReady'
have hrecWF :
NodeWF t false (composedDelete t x child) := by
simpa [RawDeleteResult] using hrec.2.1
have hpacket :=
replaceChild_packet hparent hchild hrecWF hrec.2.2 hrec.1
have hraw :=
rawDeleteResult_of_nodeWF hpacket.1
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t x (node ks cs) =
node ks (cs.set (findChild ks x) (composedDelete t x child)) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
rw [hsep]
rw [hchild]
simp [hchildReady]
exact fun heq => (hne heq).elim
rw [hdeleteEq]
exact And.intro hpacket.2.2 (And.intro hraw hpacket.2.1)
case case8 =>
rename_i x ks cs hnonempty i hpos ki oldSep hsepOld hne child hchild
hchildNotReady left hleft hleftReady sep hsep ih
simp only [i] at hpos hchild hleft hsep
simp only [ki, i] at hsepOld
have holdSepEq : oldSep = sep :=
Option.some.inj (hsepOld.symm.trans hsep)
subst oldSep
have hchildAt :
cs[(findChild ks x - 1) + 1]? = some child := by
simpa [show findChild ks x - 1 + 1 = findChild ks x by omega]
using hchild
obtain ⟨hleftWF, hchildWF, hsiblings, hleftLe, hchildGe⟩ :=
hparent.adjacent_children hsep hleft hchildAt
have hchildMin : numKeys child = t - 1 :=
numKeys_eq_t_sub_one_of_not_ready hchildWF.occupancy
hchildNotReady
have hrotated :=
rotateLeft_nodeWF ht hleftWF hchildWF hleftReady hchildMin
hsiblings hleftLe hchildGe
have htargetWF :
NodeWF t false (rotateLeft left sep child).2.2 :=
hrotated.2.1
have htargetReady :
DeleteReady t false (rotateLeft left sep child).2.2 :=
rotateLeft_repaired_deleteReady ht hleftReady hchildMin
have hrec := ih false htargetWF htargetReady
have hrecWF :
NodeWF t false
(composedDelete t x (rotateLeft left sep child).2.2) := by
simpa [RawDeleteResult] using hrec.2.1
have hpacketRaw :=
rotateLeft_reassembly_packet ht hparent hsep hleft hchildAt
hleftReady hchildMin hrecWF hrec.2.2 hrec.1
have hpacket :
NodeWF t b
(node
(ks.set (findChild ks x - 1)
(rotateLeft left sep child).2.1)
((cs.set (findChild ks x - 1)
(rotateLeft left sep child).1).set
(findChild ks x)
(composedDelete t x
(rotateLeft left sep child).2.2))) ∧
heightOf
(node
(ks.set (findChild ks x - 1)
(rotateLeft left sep child).2.1)
((cs.set (findChild ks x - 1)
(rotateLeft left sep child).1).set
(findChild ks x)
(composedDelete t x
(rotateLeft left sep child).2.2))) =
heightOf (node ks cs) ∧
KeysSubset
(node
(ks.set (findChild ks x - 1)
(rotateLeft left sep child).2.1)
((cs.set (findChild ks x - 1)
(rotateLeft left sep child).1).set
(findChild ks x)
(composedDelete t x
(rotateLeft left sep child).2.2)))
(node ks cs) := by
simpa [show findChild ks x - 1 + 1 = findChild ks x by omega]
using hpacketRaw
have hraw :=
rawDeleteResult_of_nodeWF hpacket.1
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t x (node ks cs) =
node
(ks.set (findChild ks x - 1)
(rotateLeft left sep child).2.1)
((cs.set (findChild ks x - 1)
(rotateLeft left sep child).1).set
(findChild ks x)
(composedDelete t x
(rotateLeft left sep child).2.2)) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
rw [hsepOld]
rw [hchild]
rw [hleft]
simp [hne, hchildNotReady, hleftReady]
rw [hdeleteEq]
exact And.intro hpacket.2.2 (And.intro hraw hpacket.2.1)
case case10 =>
rename_i x ks cs hnonempty i hpos ki oldSep hsepOld hne child hchild
hchildNotReady left hleft hleftNotReady right hright hrightReady
sep hsep ih
simp only [i] at hpos hchild hleft hright hsep
simp only [ki, i] at hsepOld
obtain ⟨hchildWF, hrightWF, hsiblings, hchildLe, hrightGe⟩ :=
hparent.adjacent_children hsep hchild hright
have hchildMin : numKeys child = t - 1 :=
numKeys_eq_t_sub_one_of_not_ready hchildWF.occupancy
hchildNotReady
have hrotated :=
rotateRight_nodeWF ht hchildWF hrightWF hchildMin hrightReady
hsiblings hchildLe hrightGe
have htargetWF :
NodeWF t false (rotateRight child sep right).1 :=
hrotated.1
have htargetReady :
DeleteReady t false (rotateRight child sep right).1 :=
rotateRight_repaired_deleteReady ht hchildMin hrightReady
have hrec := ih false htargetWF htargetReady
have hrecWF :
NodeWF t false
(composedDelete t x (rotateRight child sep right).1) := by
simpa [RawDeleteResult] using hrec.2.1
have hpacket :=
rotateRight_reassembly_packet ht hparent hsep hchild hright
hchildMin hrightReady hrecWF hrec.2.2 hrec.1
have hraw :=
rawDeleteResult_of_nodeWF hpacket.1
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t x (node ks cs) =
node
(ks.set (findChild ks x)
(rotateRight child sep right).2.1)
((cs.set (findChild ks x)
(composedDelete t x
(rotateRight child sep right).1)).set
(findChild ks x + 1)
(rotateRight child sep right).2.2) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
rw [hsepOld]
rw [hchild]
rw [hleft]
rw [hright]
rw [hsep]
simp [hne, hchildNotReady, hleftNotReady, hrightReady]
rw [hdeleteEq]
exact And.intro hpacket.2.2 (And.intro hraw hpacket.2.1)
case case12 =>
rename_i x ks cs hnonempty i hpos ki oldSep hsepOld hne child hchild
hchildNotReady left hleft hleftNotReady rightSib hrightSib
hrightNotReady sep hsep ih
simp only [i] at hpos hchild hleft hrightSib hsep
simp only [ki, i] at hsepOld
have holdSepEq : oldSep = sep :=
Option.some.inj (hsepOld.symm.trans hsep)
subst oldSep
have hchildAt :
cs[(findChild ks x - 1) + 1]? = some child := by
simpa [show findChild ks x - 1 + 1 = findChild ks x by omega]
using hchild
obtain ⟨hleftWF, hchildWF, hsiblings, hleftLe, hchildGe⟩ :=
hparent.adjacent_children hsep hleft hchildAt
have htarget :=
mergeNodes_recursiveTarget ht hleftWF hchildWF
hleftNotReady hchildNotReady hsiblings hleftLe hchildGe
have hrec := ih false htarget.1 htarget.2.1
have hrecWF :
NodeWF t false
(composedDelete t x (mergeNodes left sep child)) := by
simpa [RawDeleteResult] using hrec.2.1
have hpacket :=
spliceMerged_left_packet hpos hparent hready hsep hleft hchild
hrecWF hrec.2.2 hrec.1
have hraw :
RawDeleteResult t b
(node
(ks.take (findChild ks x - 1) ++ ks.drop (findChild ks x))
(cs.take (findChild ks x - 1) ++
[composedDelete t x (mergeNodes left sep child)] ++
cs.drop (findChild ks x + 1))) := by
simpa [RawDeleteResult] using hpacket.1
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t x (node ks cs) =
node
(ks.take (findChild ks x - 1) ++ ks.drop (findChild ks x))
(cs.take (findChild ks x - 1) ++
[composedDelete t x (mergeNodes left sep child)] ++
cs.drop (findChild ks x + 1)) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
rw [hsepOld]
rw [hchild]
rw [hleft]
rw [hrightSib]
simp [hne, hchildNotReady, hleftNotReady, hrightNotReady]
rw [hdeleteEq]
exact And.intro hpacket.2.2 (And.intro hraw hpacket.2.1)
case case14 =>
rename_i x ks cs hnonempty i hpos ki oldSep hsepOld hne child hchild
hchildNotReady left hleft hleftNotReady hrightNone sep hsep ih
simp only [i] at hpos hchild hleft hrightNone hsep
simp only [ki, i] at hsepOld
have holdSepEq : oldSep = sep :=
Option.some.inj (hsepOld.symm.trans hsep)
subst oldSep
have hchildAt :
cs[(findChild ks x - 1) + 1]? = some child := by
simpa [show findChild ks x - 1 + 1 = findChild ks x by omega]
using hchild
obtain ⟨hleftWF, hchildWF, hsiblings, hleftLe, hchildGe⟩ :=
hparent.adjacent_children hsep hleft hchildAt
have htarget :=
mergeNodes_recursiveTarget ht hleftWF hchildWF
hleftNotReady hchildNotReady hsiblings hleftLe hchildGe
have hrec := ih false htarget.1 htarget.2.1
have hrecWF :
NodeWF t false
(composedDelete t x (mergeNodes left sep child)) := by
simpa [RawDeleteResult] using hrec.2.1
have hpacket :=
spliceMerged_left_packet hpos hparent hready hsep hleft hchild
hrecWF hrec.2.2 hrec.1
have hraw :
RawDeleteResult t b
(node
(ks.take (findChild ks x - 1) ++ ks.drop (findChild ks x))
(cs.take (findChild ks x - 1) ++
[composedDelete t x (mergeNodes left sep child)] ++
cs.drop (findChild ks x + 1))) := by
simpa [RawDeleteResult] using hpacket.1
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t x (node ks cs) =
node
(ks.take (findChild ks x - 1) ++ ks.drop (findChild ks x))
(cs.take (findChild ks x - 1) ++
[composedDelete t x (mergeNodes left sep child)] ++
cs.drop (findChild ks x + 1)) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
rw [hsepOld]
rw [hchild]
rw [hleft]
rw [hrightNone]
simp [hne, hchildNotReady, hleftNotReady]
rw [hdeleteEq]
exact And.intro hpacket.2.2 (And.intro hraw hpacket.2.1)
case case29 =>
rename_i x ks cs hnonempty i hnotPos child hchild hchildReady ih
simp only [i] at hnotPos
have hchildMem : child ∈ cs :=
List.mem_iff_getElem?.mpr ⟨0, hchild⟩
have hchildWF : NodeWF t false child :=
hparent.child hchildMem
have hchildReady' : DeleteReady t false child := by
simpa [DeleteReady] using hchildReady
have hrec := ih false hchildWF hchildReady'
have hrecWF :
NodeWF t false (composedDelete t x child) := by
simpa [RawDeleteResult] using hrec.2.1
have hpacket :=
replaceChild_packet hparent hchild hrecWF hrec.2.2 hrec.1
have hraw :=
rawDeleteResult_of_nodeWF hpacket.1
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t x (node ks cs) =
node ks (cs.set 0 (composedDelete t x child)) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte]
rw [hchild]
simp [hchildReady]
exact fun hpos => (hnotPos hpos).elim
rw [hdeleteEq]
exact And.intro hpacket.2.2 (And.intro hraw hpacket.2.1)
case case30 =>
rename_i x ks cs hnonempty i hnotPos child hchild hchildNotReady
right hright hrightReady sep hsep ih
simp only [i] at hnotPos
obtain ⟨hchildWF, hrightWF, hsiblings, hchildLe, hrightGe⟩ :=
hparent.adjacent_children hsep hchild hright
have hchildMin : numKeys child = t - 1 :=
numKeys_eq_t_sub_one_of_not_ready hchildWF.occupancy
hchildNotReady
have hrotated :=
rotateRight_nodeWF ht hchildWF hrightWF hchildMin hrightReady
hsiblings hchildLe hrightGe
have htargetWF :
NodeWF t false (rotateRight child sep right).1 :=
hrotated.1
have htargetReady :
DeleteReady t false (rotateRight child sep right).1 :=
rotateRight_repaired_deleteReady ht hchildMin hrightReady
have hrec := ih false htargetWF htargetReady
have hrecWF :
NodeWF t false
(composedDelete t x (rotateRight child sep right).1) := by
simpa [RawDeleteResult] using hrec.2.1
have hpacket :=
rotateRight_reassembly_packet ht hparent hsep hchild hright
hchildMin hrightReady hrecWF hrec.2.2 hrec.1
have hraw :=
rawDeleteResult_of_nodeWF hpacket.1
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t x (node ks cs) =
node (ks.set 0 (rotateRight child sep right).2.1)
((cs.set 0
(composedDelete t x
(rotateRight child sep right).1)).set 1
(rotateRight child sep right).2.2) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte]
rw [dif_neg hnotPos]
rw [hchild]
simp only
rw [dif_neg hchildNotReady]
rw [hright]
simp only
rw [dif_pos hrightReady]
rw [hsep]
rw [hdeleteEq]
exact And.intro hpacket.2.2 (And.intro hraw hpacket.2.1)
case case32 =>
rename_i x ks cs hnonempty i hnotPos child hchild hchildNotReady
right hright hrightNotReady sep hsep ih
simp only [i] at hnotPos
obtain ⟨hchildWF, hrightWF, hsiblings, hchildLe, hrightGe⟩ :=
hparent.adjacent_children hsep hchild hright
have htarget :=
mergeNodes_recursiveTarget ht hchildWF hrightWF
hchildNotReady hrightNotReady hsiblings hchildLe hrightGe
have hrec := ih false htarget.1 htarget.2.1
have hrecWF :
NodeWF t false
(composedDelete t x (mergeNodes child sep right)) := by
simpa [RawDeleteResult] using hrec.2.1
have hpacket :=
spliceMerged_zero_packet hparent hready hsep hchild hright
hrecWF hrec.2.2 hrec.1
have hraw :
RawDeleteResult t b
(node (ks.drop 1)
([composedDelete t x (mergeNodes child sep right)] ++
cs.drop 2)) := by
simpa [RawDeleteResult] using hpacket.1
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t x (node ks cs) =
node (ks.drop 1)
([composedDelete t x (mergeNodes child sep right)] ++
cs.drop 2) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte]
rw [dif_neg hnotPos]
rw [hchild]
simp only
rw [dif_neg hchildNotReady]
rw [hright]
simp only
rw [dif_neg hrightNotReady]
rw [hsep]
rw [hdeleteEq]
exact And.intro hpacket.2.2 (And.intro hraw hpacket.2.1)
all_goals
exfalso
try dsimp only at *
first
| apply findChild_predecessor_none_absurd
· assumption
· assumption
| apply hparent.findChild_leftSibling_none_absurd
· assumption
| apply hparent.findChild_none_absurd
· assumption
| have hrel := hparent.children_rel
have htwo :=
hparent.two_le_children_of_not_empty ht (by simp_all)
simp_all [List.getElem?_eq_some_iff]
all_goals
obtain ⟨hindex, _⟩ := ‹∃ h : _ < _, _›
omegaRaw deletion at a non-root node preserves its invariant packet, represented keys, and height when the CLRS descent guard holds.
theorem composedDelete_nonRoot_preserves
(t x : Nat) (ht : 2 ≤ t) {tr : BTree}
(hinv : NodeWF t false tr)
(hready : t ≤ numKeys tr) :
let out := composedDelete t x tr
KeysSubset out tr ∧
NodeWF t false out ∧
heightOf out = heightOf tr := by
have hpacket :=
composedDelete_packet t ht x tr false hinv
(by simpa [DeleteReady] using hready)
simpa [RawDeleteResult] using hpacketRaw deletion at the root preserves keys and height and returns either an ordinary root or the single-child transient consumed by root normalization.
theorem composedDelete_rootResult
(t x : Nat) (ht : 2 ≤ t) {tr : BTree}
(hwf : WellFormed t tr) :
let out := composedDelete t x tr
KeysSubset out tr ∧
RootDeleteResult t out ∧
heightOf out = heightOf tr := by
have hpacket :=
composedDelete_packet t ht x tr true hwf (deleteReady_root t tr)
simpa [RawDeleteResult] using hpacketend CLRS.Chapter18.BTreeCLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.Exact
Exact semantics for raw B-tree deletion
This module proves that executable CLRS deletion removes exactly one occurrence of the requested key. The core theorem needs only the node invariant and the minimum-degree bound; uniqueness and top-level descent readiness are not required.
namespace CLRS.Chapter18.BTreeprivate theorem NodeWF.node_keys_pairwise
{t : Nat} {b : Bool} {ks : List Nat} {cs : List BTree}
(h : NodeWF t b (node ks cs)) :
List.Pairwise (· ≤ ·) ks := by
have hs := h.sorted
unfold Sorted at hs
exact hs.1
private theorem composedDelete_keyBag_aux
(t : Nat) (ht : 2 ≤ t) (x : Nat) (tr : BTree) :
∀ b, NodeWF t b tr →
keyBag (composedDelete t x tr) = (keyBag tr).erase x := by
induction x, tr using composedDelete.induct (t := t) <;>
intro b hparent
case case1 =>
rename_i x ks cs hleaf
have hcs : cs = [] := List.isEmpty_iff.mp hleaf
subst cs
simpa [composedDelete, keyBag, keysOf] using
(sortedRemove_keyBag x ks)
case case2 =>
rename_i ks cs hnonempty sep left right hleftReady i hpos ki hsep hleft hright ih
simp only [i] at hpos
simp only [ki, i] at hsep hleft hright
have hleftMem : left ∈ cs :=
List.mem_iff_getElem?.mpr ⟨findChild ks sep - 1, hleft⟩
have hleftWF : NodeWF t false left :=
hparent.child hleftMem
have hrec := ih false hleftWF
have hexact :=
replacePredecessor_keyBag_erase ht hparent hsep hleft hrec
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t sep (node ks cs) =
node (ks.set (findChild ks sep - 1) (maxKey left))
(cs.set (findChild ks sep - 1)
(composedDelete t (maxKey left) left)) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
rw [hsep]
rw [hleft, hright]
simp [hleftReady]
rw [hdeleteEq]
exact hexact
case case3 =>
rename_i ks cs hnonempty sep left right hleftNotReady hrightReady
i hpos ki hsep hleft hright ih
simp only [i] at hpos
simp only [ki, i] at hsep hleft hright
have hrightMem : right ∈ cs :=
List.mem_iff_getElem?.mpr ⟨findChild ks sep - 1 + 1, hright⟩
have hrightWF : NodeWF t false right :=
hparent.child hrightMem
have hrec := ih false hrightWF
have hexact :=
replaceSuccessor_keyBag_erase ht hparent hsep hright hrec
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t sep (node ks cs) =
node (ks.set (findChild ks sep - 1) (minKey right))
(cs.set (findChild ks sep - 1 + 1)
(composedDelete t (minKey right) right)) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
rw [hsep]
rw [hleft, hright]
simp [hleftNotReady, hrightReady]
rw [hdeleteEq]
exact hexact
case case4 =>
rename_i ks cs hnonempty sep left right hleftNotReady hrightNotReady
merged i hpos ki hsep hleft hright ih
simp only [i] at hpos
simp only [ki, i] at hsep hleft hright
obtain ⟨hleftWF, hrightWF, hsiblings, hleftLe, hrightGe⟩ :=
hparent.adjacent_children hsep hleft hright
have hleftMin : numKeys left = t - 1 :=
numKeys_eq_t_sub_one_of_not_ready hleftWF.occupancy hleftNotReady
have hrightMin : numKeys right = t - 1 :=
numKeys_eq_t_sub_one_of_not_ready hrightWF.occupancy hrightNotReady
have hmerged :=
mergeNodes_nodeWF ht hleftWF hrightWF hleftMin hrightMin
hsiblings hleftLe hrightGe
have hmergedWF : NodeWF t false merged := by
simpa [merged] using hmerged.1
have hrec := ih false hmergedWF
have hroute :
sep ∈ keysOf (node ks cs) →
sep ∈ keysOf (mergeNodes left sep right) := by
intro _
exact
(mem_keysOf_mergeNodes left sep right sep).2
(Or.inr (Or.inl rfl))
have hexact :=
spliceMerged_keyBag_erase hsep hleft hright hroute
(by simpa [merged] using hrec)
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t sep (node ks cs) =
node
(ks.take (findChild ks sep - 1) ++
ks.drop (findChild ks sep - 1 + 1))
(cs.take (findChild ks sep - 1) ++
[composedDelete t sep merged] ++
cs.drop (findChild ks sep - 1 + 2)) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
rw [hsep]
rw [hleft, hright]
simp [hleftNotReady, hrightNotReady, merged]
rw [hdeleteEq]
exact hexact
case case7 =>
rename_i x ks cs hnonempty i hpos ki oldSep hsep hne child hchild
hchildReady ih
simp only [i] at hpos
simp only [ki, i] at hsep
simp only [i] at hchild
have hxkeys : x ∉ ks := by
intro hx
have hfound :=
findChild_pos_and_pred_eq_of_mem hparent.node_keys_pairwise hx
have holdEq : oldSep = x :=
Option.some.inj (hsep.symm.trans hfound.2)
exact hne holdEq
have hroute :
x ∈ keysOf (node ks cs) → x ∈ keysOf child :=
findChild_selected_child_mem hparent.node_keys_pairwise
hparent.childBounded hxkeys hchild
have hchildMem : child ∈ cs :=
List.mem_iff_getElem?.mpr ⟨findChild ks x, hchild⟩
have hchildWF : NodeWF t false child :=
hparent.child hchildMem
have hrec := ih false hchildWF
have hexact :=
replaceChild_keyBag_erase hchild hroute hrec
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t x (node ks cs) =
node ks (cs.set (findChild ks x) (composedDelete t x child)) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
rw [hsep]
rw [hchild]
simp [hchildReady]
exact fun heq => (hne heq).elim
rw [hdeleteEq]
exact hexact
case case8 =>
rename_i x ks cs hnonempty i hpos ki oldSep hsepOld hne child hchild
hchildNotReady left hleft hleftReady sep hsep ih
simp only [i] at hpos hchild hleft hsep
simp only [ki, i] at hsepOld
have holdSepEq : oldSep = sep :=
Option.some.inj (hsepOld.symm.trans hsep)
subst oldSep
have hxkeys : x ∉ ks := by
intro hx
have hfound :=
findChild_pos_and_pred_eq_of_mem hparent.node_keys_pairwise hx
have hsepEq : sep = x :=
Option.some.inj (hsep.symm.trans hfound.2)
exact hne hsepEq
have hroute :
x ∈ keysOf (node ks cs) → x ∈ keysOf child :=
findChild_selected_child_mem hparent.node_keys_pairwise
hparent.childBounded hxkeys hchild
have hchildAt :
cs[(findChild ks x - 1) + 1]? = some child := by
simpa [show findChild ks x - 1 + 1 = findChild ks x by omega]
using hchild
obtain ⟨hleftWF, hchildWF, hsiblings, hleftLe, hchildGe⟩ :=
hparent.adjacent_children hsep hleft hchildAt
have hchildMin : numKeys child = t - 1 :=
numKeys_eq_t_sub_one_of_not_ready hchildWF.occupancy
hchildNotReady
have hrotated :=
rotateLeft_nodeWF ht hleftWF hchildWF hleftReady hchildMin
hsiblings hleftLe hchildGe
have htargetWF :
NodeWF t false (rotateLeft left sep child).2.2 :=
hrotated.2.1
have hrec := ih false htargetWF
have hexactRaw :=
rotateLeft_reassembly_keyBag_erase
hsep hleft hchildAt hroute hrec
have hexact :
keyBag
(node
(ks.set (findChild ks x - 1)
(rotateLeft left sep child).2.1)
((cs.set (findChild ks x - 1)
(rotateLeft left sep child).1).set
(findChild ks x)
(composedDelete t x
(rotateLeft left sep child).2.2))) =
(keyBag (node ks cs)).erase x := by
simpa [show findChild ks x - 1 + 1 = findChild ks x by omega]
using hexactRaw
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t x (node ks cs) =
node
(ks.set (findChild ks x - 1)
(rotateLeft left sep child).2.1)
((cs.set (findChild ks x - 1)
(rotateLeft left sep child).1).set
(findChild ks x)
(composedDelete t x
(rotateLeft left sep child).2.2)) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
rw [hsepOld]
rw [hchild]
rw [hleft]
simp [hne, hchildNotReady, hleftReady]
rw [hdeleteEq]
exact hexact
case case10 =>
rename_i x ks cs hnonempty i hpos ki oldSep hsepOld hne child hchild
hchildNotReady left hleft hleftNotReady right hright hrightReady
sep hsep ih
simp only [i] at hpos hchild hleft hright hsep
simp only [ki, i] at hsepOld
have hxkeys : x ∉ ks := by
intro hx
have hfound :=
findChild_pos_and_pred_eq_of_mem hparent.node_keys_pairwise hx
have holdEq : oldSep = x :=
Option.some.inj (hsepOld.symm.trans hfound.2)
exact hne holdEq
have hroute :
x ∈ keysOf (node ks cs) → x ∈ keysOf child :=
findChild_selected_child_mem hparent.node_keys_pairwise
hparent.childBounded hxkeys hchild
obtain ⟨hchildWF, hrightWF, hsiblings, hchildLe, hrightGe⟩ :=
hparent.adjacent_children hsep hchild hright
have hchildMin : numKeys child = t - 1 :=
numKeys_eq_t_sub_one_of_not_ready hchildWF.occupancy
hchildNotReady
have hrotated :=
rotateRight_nodeWF ht hchildWF hrightWF hchildMin hrightReady
hsiblings hchildLe hrightGe
have htargetWF :
NodeWF t false (rotateRight child sep right).1 :=
hrotated.1
have hrec := ih false htargetWF
have hexact :=
rotateRight_reassembly_keyBag_erase
hsep hchild hright hroute hrec
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t x (node ks cs) =
node
(ks.set (findChild ks x)
(rotateRight child sep right).2.1)
((cs.set (findChild ks x)
(composedDelete t x
(rotateRight child sep right).1)).set
(findChild ks x + 1)
(rotateRight child sep right).2.2) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
rw [hsepOld]
rw [hchild]
rw [hleft]
rw [hright]
rw [hsep]
simp [hne, hchildNotReady, hleftNotReady, hrightReady]
rw [hdeleteEq]
exact hexact
case case12 =>
rename_i x ks cs hnonempty i hpos ki oldSep hsepOld hne child hchild
hchildNotReady left hleft hleftNotReady rightSib hrightSib
hrightNotReady sep hsep ih
simp only [i] at hpos hchild hleft hrightSib hsep
simp only [ki, i] at hsepOld
have holdSepEq : oldSep = sep :=
Option.some.inj (hsepOld.symm.trans hsep)
subst oldSep
have hxkeys : x ∉ ks := by
intro hx
have hfound :=
findChild_pos_and_pred_eq_of_mem hparent.node_keys_pairwise hx
have hsepEq : sep = x :=
Option.some.inj (hsep.symm.trans hfound.2)
exact hne hsepEq
have hrouteChild :
x ∈ keysOf (node ks cs) → x ∈ keysOf child :=
findChild_selected_child_mem hparent.node_keys_pairwise
hparent.childBounded hxkeys hchild
have hchildAt :
cs[(findChild ks x - 1) + 1]? = some child := by
simpa [show findChild ks x - 1 + 1 = findChild ks x by omega]
using hchild
obtain ⟨hleftWF, hchildWF, hsiblings, hleftLe, hchildGe⟩ :=
hparent.adjacent_children hsep hleft hchildAt
have htarget :=
mergeNodes_recursiveTarget ht hleftWF hchildWF
hleftNotReady hchildNotReady hsiblings hleftLe hchildGe
have hrec := ih false htarget.1
have hroute :
x ∈ keysOf (node ks cs) →
x ∈ keysOf (mergeNodes left sep child) := by
intro hx
exact
(mem_keysOf_mergeNodes left sep child x).2
(Or.inr (Or.inr (hrouteChild hx)))
have hexactRaw :=
spliceMerged_keyBag_erase hsep hleft hchildAt hroute hrec
have hexact :
keyBag
(node
(ks.take (findChild ks x - 1) ++ ks.drop (findChild ks x))
(cs.take (findChild ks x - 1) ++
[composedDelete t x (mergeNodes left sep child)] ++
cs.drop (findChild ks x + 1))) =
(keyBag (node ks cs)).erase x := by
simpa [show findChild ks x - 1 + 1 = findChild ks x by omega,
show findChild ks x - 1 + 2 = findChild ks x + 1 by omega]
using hexactRaw
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t x (node ks cs) =
node
(ks.take (findChild ks x - 1) ++ ks.drop (findChild ks x))
(cs.take (findChild ks x - 1) ++
[composedDelete t x (mergeNodes left sep child)] ++
cs.drop (findChild ks x + 1)) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
rw [hsepOld]
rw [hchild]
rw [hleft]
rw [hrightSib]
simp [hne, hchildNotReady, hleftNotReady, hrightNotReady]
rw [hdeleteEq]
exact hexact
case case14 =>
rename_i x ks cs hnonempty i hpos ki oldSep hsepOld hne child hchild
hchildNotReady left hleft hleftNotReady hrightNone sep hsep ih
simp only [i] at hpos hchild hleft hrightNone hsep
simp only [ki, i] at hsepOld
have holdSepEq : oldSep = sep :=
Option.some.inj (hsepOld.symm.trans hsep)
subst oldSep
have hxkeys : x ∉ ks := by
intro hx
have hfound :=
findChild_pos_and_pred_eq_of_mem hparent.node_keys_pairwise hx
have hsepEq : sep = x :=
Option.some.inj (hsep.symm.trans hfound.2)
exact hne hsepEq
have hrouteChild :
x ∈ keysOf (node ks cs) → x ∈ keysOf child :=
findChild_selected_child_mem hparent.node_keys_pairwise
hparent.childBounded hxkeys hchild
have hchildAt :
cs[(findChild ks x - 1) + 1]? = some child := by
simpa [show findChild ks x - 1 + 1 = findChild ks x by omega]
using hchild
obtain ⟨hleftWF, hchildWF, hsiblings, hleftLe, hchildGe⟩ :=
hparent.adjacent_children hsep hleft hchildAt
have htarget :=
mergeNodes_recursiveTarget ht hleftWF hchildWF
hleftNotReady hchildNotReady hsiblings hleftLe hchildGe
have hrec := ih false htarget.1
have hroute :
x ∈ keysOf (node ks cs) →
x ∈ keysOf (mergeNodes left sep child) := by
intro hx
exact
(mem_keysOf_mergeNodes left sep child x).2
(Or.inr (Or.inr (hrouteChild hx)))
have hexactRaw :=
spliceMerged_keyBag_erase hsep hleft hchildAt hroute hrec
have hexact :
keyBag
(node
(ks.take (findChild ks x - 1) ++ ks.drop (findChild ks x))
(cs.take (findChild ks x - 1) ++
[composedDelete t x (mergeNodes left sep child)] ++
cs.drop (findChild ks x + 1))) =
(keyBag (node ks cs)).erase x := by
simpa [show findChild ks x - 1 + 1 = findChild ks x by omega,
show findChild ks x - 1 + 2 = findChild ks x + 1 by omega]
using hexactRaw
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t x (node ks cs) =
node
(ks.take (findChild ks x - 1) ++ ks.drop (findChild ks x))
(cs.take (findChild ks x - 1) ++
[composedDelete t x (mergeNodes left sep child)] ++
cs.drop (findChild ks x + 1)) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
rw [hsepOld]
rw [hchild]
rw [hleft]
rw [hrightNone]
simp [hne, hchildNotReady, hleftNotReady]
rw [hdeleteEq]
exact hexact
case case29 =>
rename_i x ks cs hnonempty i hnotPos child hchild hchildReady ih
simp only [i] at hnotPos
have hfindZero : findChild ks x = 0 :=
Nat.eq_zero_of_not_pos hnotPos
have hxkeys : x ∉ ks := by
intro hx
exact hnotPos
(findChild_pos_and_pred_eq_of_mem hparent.node_keys_pairwise hx).1
have hchildSelected :
cs[findChild ks x]? = some child := by
simpa [hfindZero] using hchild
have hroute :
x ∈ keysOf (node ks cs) → x ∈ keysOf child :=
findChild_selected_child_mem hparent.node_keys_pairwise
hparent.childBounded hxkeys hchildSelected
have hchildMem : child ∈ cs :=
List.mem_iff_getElem?.mpr ⟨0, hchild⟩
have hchildWF : NodeWF t false child :=
hparent.child hchildMem
have hrec := ih false hchildWF
have hexact :=
replaceChild_keyBag_erase hchild hroute hrec
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t x (node ks cs) =
node ks (cs.set 0 (composedDelete t x child)) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte]
rw [hchild]
simp [hchildReady]
exact fun hpos => (hnotPos hpos).elim
rw [hdeleteEq]
exact hexact
case case30 =>
rename_i x ks cs hnonempty i hnotPos child hchild hchildNotReady
right hright hrightReady sep hsep ih
simp only [i] at hnotPos
have hfindZero : findChild ks x = 0 :=
Nat.eq_zero_of_not_pos hnotPos
have hxkeys : x ∉ ks := by
intro hx
exact hnotPos
(findChild_pos_and_pred_eq_of_mem hparent.node_keys_pairwise hx).1
have hchildSelected :
cs[findChild ks x]? = some child := by
simpa [hfindZero] using hchild
have hroute :
x ∈ keysOf (node ks cs) → x ∈ keysOf child :=
findChild_selected_child_mem hparent.node_keys_pairwise
hparent.childBounded hxkeys hchildSelected
obtain ⟨hchildWF, hrightWF, hsiblings, hchildLe, hrightGe⟩ :=
hparent.adjacent_children hsep hchild hright
have hchildMin : numKeys child = t - 1 :=
numKeys_eq_t_sub_one_of_not_ready hchildWF.occupancy
hchildNotReady
have hrotated :=
rotateRight_nodeWF ht hchildWF hrightWF hchildMin hrightReady
hsiblings hchildLe hrightGe
have htargetWF :
NodeWF t false (rotateRight child sep right).1 :=
hrotated.1
have hrec := ih false htargetWF
have hexact :=
rotateRight_reassembly_keyBag_erase hsep hchild hright hroute hrec
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t x (node ks cs) =
node (ks.set 0 (rotateRight child sep right).2.1)
((cs.set 0
(composedDelete t x
(rotateRight child sep right).1)).set 1
(rotateRight child sep right).2.2) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte]
rw [dif_neg hnotPos]
rw [hchild]
simp only
rw [dif_neg hchildNotReady]
rw [hright]
simp only
rw [dif_pos hrightReady]
rw [hsep]
rw [hdeleteEq]
exact hexact
case case32 =>
rename_i x ks cs hnonempty i hnotPos child hchild hchildNotReady
right hright hrightNotReady sep hsep ih
simp only [i] at hnotPos
have hfindZero : findChild ks x = 0 :=
Nat.eq_zero_of_not_pos hnotPos
have hxkeys : x ∉ ks := by
intro hx
exact hnotPos
(findChild_pos_and_pred_eq_of_mem hparent.node_keys_pairwise hx).1
have hchildSelected :
cs[findChild ks x]? = some child := by
simpa [hfindZero] using hchild
have hrouteChild :
x ∈ keysOf (node ks cs) → x ∈ keysOf child :=
findChild_selected_child_mem hparent.node_keys_pairwise
hparent.childBounded hxkeys hchildSelected
obtain ⟨hchildWF, hrightWF, hsiblings, hchildLe, hrightGe⟩ :=
hparent.adjacent_children hsep hchild hright
have htarget :=
mergeNodes_recursiveTarget ht hchildWF hrightWF
hchildNotReady hrightNotReady hsiblings hchildLe hrightGe
have hrec := ih false htarget.1
have hroute :
x ∈ keysOf (node ks cs) →
x ∈ keysOf (mergeNodes child sep right) := by
intro hx
exact
(mem_keysOf_mergeNodes child sep right x).2
(Or.inl (hrouteChild hx))
have hexact :=
spliceMerged_keyBag_erase hsep hchild hright hroute hrec
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t x (node ks cs) =
node (ks.drop 1)
([composedDelete t x (mergeNodes child sep right)] ++
cs.drop 2) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte]
rw [dif_neg hnotPos]
rw [hchild]
simp only
rw [dif_neg hchildNotReady]
rw [hright]
simp only
rw [dif_neg hrightNotReady]
rw [hsep]
rw [hdeleteEq]
simpa using hexact
all_goals
exfalso
try dsimp only at *
first
| apply findChild_predecessor_none_absurd
· assumption
· assumption
| apply hparent.findChild_leftSibling_none_absurd
· assumption
| apply hparent.findChild_none_absurd
· assumption
| have hrel := hparent.children_rel
have htwo :=
hparent.two_le_children_of_not_empty ht (by simp_all)
simp_all [List.getElem?_eq_some_iff]
all_goals
obtain ⟨hindex, _⟩ := ‹∃ h : _ < _, _›
omegaExecutable CLRS deletion removes exactly one occurrence of the requested key. No uniqueness assumption and no top-level descent-readiness premise are needed.
theorem composedDelete_keyBag
(t x : Nat) (ht : 2 ≤ t) {tr : BTree} {b : Bool}
(hinv : NodeWF t b tr) :
keyBag (composedDelete t x tr) =
(keyBag tr).erase x := by
exact composedDelete_keyBag_aux t ht x tr b hinvDeletion preserves membership of every key distinct from the request.
theorem composedDelete_mem_iff_of_ne
(t x y : Nat) (ht : 2 ≤ t) {tr : BTree} {b : Bool}
(hinv : NodeWF t b tr) (hyx : y ≠ x) :
mem y (composedDelete t x tr) ↔ mem y tr := by
have hbag := composedDelete_keyBag t x ht hinv
have hmem :
y ∈ (keyBag tr).erase x ↔ y ∈ keyBag tr :=
Multiset.mem_erase_of_ne hyx
rw [← hbag] at hmem
simpa only [mem, keyBag, Multiset.mem_coe] using hmemExact one-occurrence deletion preserves uniqueness of the flattened key list.
theorem composedDelete_uniqueKeys
(t x : Nat) (ht : 2 ≤ t) {tr : BTree} {b : Bool}
(hinv : NodeWF t b tr) (hunique : UniqueKeys tr) :
UniqueKeys (composedDelete t x tr) := by
unfold UniqueKeys at hunique ⊢
have hbag := composedDelete_keyBag t x ht hinv
have hcoe :
(↑(keysOf (composedDelete t x tr)) : Multiset Nat) =
↑((keysOf tr).erase x) := by
simpa only [keyBag, Multiset.coe_erase] using hbag
have hperm :
(keysOf (composedDelete t x tr)).Perm
((keysOf tr).erase x) :=
Multiset.coe_eq_coe.mp hcoe
exact hperm.nodup_iff.mpr (List.Nodup.erase x hunique)end CLRS.Chapter18.BTreeCLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.ExactReassembly
Exact parent reassembly for B-tree deletion
This module lifts the exact key-multiset equations for primitive deletion operations through the parent-reassembly steps used by composed deletion. The proofs need only local index witnesses, recursive exactness, and routing facts; structural preservation is supplied separately by the reassembly packet modules.
namespace CLRSnamespace Chapter18namespace BTreeReplacing a witnessed child balances the new parent and old child against the old parent and new child.
theorem replaceChild_keyBag_balance
{i : Nat} {ks : List Nat} {cs : List BTree}
{old new : BTree}
(hold : cs[i]? = some old) :
keyBag (node ks (cs.set i new)) + keyBag old =
keyBag (node ks cs) + keyBag new := by
have hchildren :=
flatMap_set_bag_balance (new := new) keysOf hold
simp only [keyBag, keysOf, ← Multiset.coe_add] at hchildren ⊢
simpa only [add_assoc] using
congrArg (fun bag => (↑ks : Multiset Nat) + bag) hchildrenReplacing the routed recursive child lifts deletion of one key occurrence to the enclosing parent.
theorem replaceChild_keyBag_erase
{i x : Nat} {ks : List Nat} {cs : List BTree}
{old new : BTree}
(hold : cs[i]? = some old)
(hroute : x ∈ keysOf (node ks cs) → x ∈ keysOf old)
(hrec : keyBag new = (keyBag old).erase x) :
keyBag (node ks (cs.set i new)) =
(keyBag (node ks cs)).erase x := by
apply keyBag_erase_of_balance (replaceChild_keyBag_balance hold) hrec
simpa only [keyBag, Multiset.mem_coe] using hrouteChanging one separator and one witnessed child gives a joint key-bag balance.
theorem replaceSeparatorChild_keyBag_balance
{separatorIndex childIndex oldSep newSep : Nat}
{ks : List Nat} {cs : List BTree} {old new : BTree}
(hsep : ks[separatorIndex]? = some oldSep)
(hold : cs[childIndex]? = some old) :
keyBag
(node (ks.set separatorIndex newSep)
(cs.set childIndex new)) +
{oldSep} + keyBag old =
keyBag (node ks cs) + {newSep} + keyBag new := by
have hkeys :=
list_set_bag_balance (new := newSep) hsep
have hchildren :=
flatMap_set_bag_balance (new := new) keysOf hold
simp only [keyBag, keysOf, ← Multiset.coe_add] at hkeys hchildren ⊢
calc
(↑(ks.set separatorIndex newSep) : Multiset Nat) +
↑((cs.set childIndex new).flatMap keysOf) +
{oldSep} + ↑(keysOf old) =
((↑(ks.set separatorIndex newSep) : Multiset Nat) + {oldSep}) +
(↑((cs.set childIndex new).flatMap keysOf) + ↑(keysOf old)) := by
ac_rfl
_ = ((↑ks : Multiset Nat) + {newSep}) +
(↑(cs.flatMap keysOf) + ↑(keysOf new)) := by
rw [hkeys, hchildren]
_ = (↑ks : Multiset Nat) + ↑(cs.flatMap keysOf) +
{newSep} + ↑(keysOf new) := by
ac_rflReplacing a separator by its predecessor while recursively deleting that predecessor removes exactly the old separator from the parent key bag.
theorem replacePredecessor_keyBag_erase
{t i sep : Nat} {b : Bool}
{ks : List Nat} {cs : List BTree} {left left' : BTree}
(ht : 2 ≤ t)
(hparent : NodeWF t b (node ks cs))
(hsep : ks[i]? = some sep)
(hleft : cs[i]? = some left)
(hrec :
keyBag left' = (keyBag left).erase (maxKey left)) :
keyBag
(node (ks.set i (maxKey left)) (cs.set i left')) =
(keyBag (node ks cs)).erase sep := by
have hleftMem : left ∈ cs :=
List.mem_iff_getElem?.mpr ⟨i, hleft⟩
have hleftWF : NodeWF t false left :=
hparent.child hleftMem
have hmaxMemList : maxKey left ∈ keysOf left :=
maxKey_mem left (hleftWF.nonRoot_allKeysPos ht)
have hmaxMem : maxKey left ∈ keyBag left := by
simpa only [keyBag, Multiset.mem_coe] using hmaxMemList
have hrestore :
{maxKey left} + keyBag left' = keyBag left := by
rw [hrec, Multiset.singleton_add]
exact Multiset.cons_erase hmaxMem
have hbalance :=
replaceSeparatorChild_keyBag_balance
(newSep := maxKey left) (new := left') hsep hleft
have hframe :
keyBag
(node (ks.set i (maxKey left)) (cs.set i left')) +
{sep} =
keyBag (node ks cs) := by
apply add_right_cancel (b := keyBag left)
calc
(keyBag
(node (ks.set i (maxKey left)) (cs.set i left')) +
{sep}) +
keyBag left =
keyBag
(node (ks.set i (maxKey left)) (cs.set i left')) +
{sep} + keyBag left := by rfl
_ = keyBag (node ks cs) + {maxKey left} + keyBag left' :=
hbalance
_ = keyBag (node ks cs) +
({maxKey left} + keyBag left') := by
rw [add_assoc]
_ = keyBag (node ks cs) + keyBag left := by
rw [hrestore]
apply keyBag_erase_of_balance
(old := ({sep} : Multiset Nat)) (new := 0)
· simpa using hframe
· simp
· simpSplicing a recursive merge result into the parent balances it against the unmodified merged child.
theorem spliceMerged_keyBag_balance
{j sep : Nat} {ks : List Nat} {cs : List BTree}
{left right newMerged : BTree}
(hsep : ks[j]? = some sep)
(hleft : cs[j]? = some left)
(hright : cs[j + 1]? = some right) :
let out :=
node (ks.take j ++ ks.drop (j + 1))
(cs.take j ++ [newMerged] ++ cs.drop (j + 2))
keyBag out + keyBag (mergeNodes left sep right) =
keyBag (node ks cs) + keyBag newMerged := by
dsimp only
have hkeys :=
take_drop_succ_bag_balance hsep
have hchildren :=
flatMap_splice_bag_balance
(new := newMerged) keysOf hleft hright
have hmerge := mergeNodes_keyBag left sep right
simp only [keyBag, keysOf, ← Multiset.coe_add] at hkeys hchildren hmerge ⊢
rw [hmerge]
calc
((↑(ks.take j) : Multiset Nat) + ↑(ks.drop (j + 1))) +
↑((cs.take j ++ [newMerged] ++ cs.drop (j + 2)).flatMap keysOf) +
(keyBag left + {sep} + keyBag right) =
(((↑(ks.take j) : Multiset Nat) + ↑(ks.drop (j + 1))) + {sep}) +
(↑((cs.take j ++ [newMerged] ++ cs.drop (j + 2)).flatMap keysOf) +
↑(keysOf left) + ↑(keysOf right)) := by
simp only [keyBag]
ac_rfl
_ = (↑ks : Multiset Nat) +
(↑(cs.flatMap keysOf) + ↑(keysOf newMerged)) := by
rw [hkeys, hchildren]
_ = (↑ks : Multiset Nat) + ↑(cs.flatMap keysOf) +
↑(keysOf newMerged) := by
ac_rflAfter a merge, recursively deleting a routed key from the merged child removes exactly one occurrence from the reassembled parent.
theorem spliceMerged_keyBag_erase
{j sep x : Nat} {ks : List Nat} {cs : List BTree}
{left right newMerged : BTree}
(hsep : ks[j]? = some sep)
(hleft : cs[j]? = some left)
(hright : cs[j + 1]? = some right)
(hroute :
x ∈ keysOf (node ks cs) →
x ∈ keysOf (mergeNodes left sep right))
(hrec :
keyBag newMerged =
(keyBag (mergeNodes left sep right)).erase x) :
let out :=
node (ks.take j ++ ks.drop (j + 1))
(cs.take j ++ [newMerged] ++ cs.drop (j + 2))
keyBag out = (keyBag (node ks cs)).erase x := by
dsimp only
apply keyBag_erase_of_balance
(spliceMerged_keyBag_balance hsep hleft hright) hrec
simpa only [keyBag, Multiset.mem_coe] using hrouteReplacing a separator by its successor while recursively deleting that successor removes exactly the old separator from the parent key bag.
theorem replaceSuccessor_keyBag_erase
{t i sep : Nat} {b : Bool}
{ks : List Nat} {cs : List BTree} {right right' : BTree}
(ht : 2 ≤ t)
(hparent : NodeWF t b (node ks cs))
(hsep : ks[i]? = some sep)
(hright : cs[i + 1]? = some right)
(hrec :
keyBag right' = (keyBag right).erase (minKey right)) :
keyBag
(node (ks.set i (minKey right))
(cs.set (i + 1) right')) =
(keyBag (node ks cs)).erase sep := by
have hrightMem : right ∈ cs :=
List.mem_iff_getElem?.mpr ⟨i + 1, hright⟩
have hrightWF : NodeWF t false right :=
hparent.child hrightMem
have hminMemList : minKey right ∈ keysOf right :=
minKey_mem right (hrightWF.nonRoot_allKeysPos ht)
have hminMem : minKey right ∈ keyBag right := by
simpa only [keyBag, Multiset.mem_coe] using hminMemList
have hrestore :
{minKey right} + keyBag right' = keyBag right := by
rw [hrec, Multiset.singleton_add]
exact Multiset.cons_erase hminMem
have hbalance :=
replaceSeparatorChild_keyBag_balance
(separatorIndex := i) (childIndex := i + 1)
(newSep := minKey right) (new := right') hsep hright
have hframe :
keyBag
(node (ks.set i (minKey right))
(cs.set (i + 1) right')) +
{sep} =
keyBag (node ks cs) := by
apply add_right_cancel (b := keyBag right)
calc
(keyBag
(node (ks.set i (minKey right))
(cs.set (i + 1) right')) +
{sep}) +
keyBag right =
keyBag
(node (ks.set i (minKey right))
(cs.set (i + 1) right')) +
{sep} + keyBag right := by rfl
_ = keyBag (node ks cs) + {minKey right} + keyBag right' :=
hbalance
_ = keyBag (node ks cs) +
({minKey right} + keyBag right') := by
rw [add_assoc]
_ = keyBag (node ks cs) + keyBag right := by
rw [hrestore]
apply keyBag_erase_of_balance
(old := ({sep} : Multiset Nat)) (new := 0)
· simpa using hframe
· simp
· simpEvery key of the original left child remains in the repaired left child after a right rotation.
theorem mem_rotateRight_left_of_mem_left
(left : BTree) (sep : Nat) (right : BTree) {x : Nat}
(hx : x ∈ keysOf left) :
x ∈ keysOf (rotateRight left sep right).1 := by
rcases left with ⟨lKeys, lChildren⟩
rcases right with ⟨rKeys, rChildren⟩
cases rKeys <;>
simp only [rotateRight_nil, rotateRight_cons, keysOf,
List.mem_append, List.mem_cons,
List.mem_flatMap] at hx ⊢ <;>
aesopEvery key of the original right child remains in the repaired right child after a left rotation.
theorem mem_rotateLeft_right_of_mem_right
(left : BTree) (sep : Nat) (right : BTree) {x : Nat}
(hx : x ∈ keysOf right) :
x ∈ keysOf (rotateLeft left sep right).2.2 := by
rcases left with ⟨lKeys, lChildren⟩
rcases right with ⟨rKeys, rChildren⟩
cases lKeys <;>
simp only [rotateLeft_nil, rotateLeft_cons, keysOf,
List.mem_append, List.mem_cons, List.mem_flatMap] at hx ⊢ <;>
aesop
private theorem flatMap_set_adjacent_bag_balance
{α β : Type*} {xs : List α} {j : Nat}
{left right newLeft newRight : α}
(f : α → List β)
(hleft : xs[j]? = some left)
(hright : xs[j + 1]? = some right) :
(↑(((xs.set j newLeft).set (j + 1) newRight).flatMap f) :
Multiset β) +
↑(f left) + ↑(f right) =
(↑(xs.flatMap f) : Multiset β) +
↑(f newLeft) + ↑(f newRight) := by
have hrightAfter :
(xs.set j newLeft)[j + 1]? = some right := by
rw [List.getElem?_set_ne (by omega : j ≠ j + 1)]
exact hright
have hfirst :=
flatMap_set_bag_balance (new := newLeft) f hleft
have hsecond :=
flatMap_set_bag_balance (new := newRight) f hrightAfter
calc
(↑(((xs.set j newLeft).set (j + 1) newRight).flatMap f) :
Multiset β) +
↑(f left) + ↑(f right) =
((↑(((xs.set j newLeft).set (j + 1) newRight).flatMap f) :
Multiset β) + ↑(f right)) + ↑(f left) := by
ac_rfl
_ = ((↑((xs.set j newLeft).flatMap f) : Multiset β) +
↑(f newRight)) + ↑(f left) := by
rw [hsecond]
_ = ((↑((xs.set j newLeft).flatMap f) : Multiset β) +
↑(f left)) + ↑(f newRight) := by
ac_rfl
_ = ((↑(xs.flatMap f) : Multiset β) + ↑(f newLeft)) +
↑(f newRight) := by
rw [hfirst]Replacing one separator and both adjacent children gives an atomic key-bag balance for a rotation.
theorem replaceAdjacent_keyBag_balance
{j sep newSep : Nat} {ks : List Nat} {cs : List BTree}
{left right newLeft newRight : BTree}
(hsep : ks[j]? = some sep)
(hleft : cs[j]? = some left)
(hright : cs[j + 1]? = some right) :
keyBag
(node (ks.set j newSep)
((cs.set j newLeft).set (j + 1) newRight)) +
(keyBag left + {sep} + keyBag right) =
keyBag (node ks cs) +
(keyBag newLeft + {newSep} + keyBag newRight) := by
have hkeys :=
list_set_bag_balance (new := newSep) hsep
have hchildren :=
flatMap_set_adjacent_bag_balance
(newLeft := newLeft) (newRight := newRight)
keysOf hleft hright
simp only [keyBag, keysOf, ← Multiset.coe_add] at hkeys hchildren ⊢
calc
(↑(ks.set j newSep) : Multiset Nat) +
↑(((cs.set j newLeft).set (j + 1) newRight).flatMap keysOf) +
(↑(keysOf left) + {sep} + ↑(keysOf right)) =
((↑(ks.set j newSep) : Multiset Nat) + {sep}) +
(↑(((cs.set j newLeft).set (j + 1) newRight).flatMap keysOf) +
↑(keysOf left) + ↑(keysOf right)) := by
ac_rfl
_ = ((↑ks : Multiset Nat) + {newSep}) +
(↑(cs.flatMap keysOf) +
↑(keysOf newLeft) + ↑(keysOf newRight)) := by
rw [hkeys, hchildren]
_ = (↑ks : Multiset Nat) + ↑(cs.flatMap keysOf) +
(↑(keysOf newLeft) + {newSep} + ↑(keysOf newRight)) := by
ac_rflA right rotation preserves the complete parent key bag.
theorem rotateRight_parent_keyBag
{j sep : Nat} {ks : List Nat} {cs : List BTree}
{left right : BTree}
(hsep : ks[j]? = some sep)
(hleft : cs[j]? = some left)
(hright : cs[j + 1]? = some right) :
let repaired := rotateRight left sep right
keyBag
(node (ks.set j repaired.2.1)
((cs.set j repaired.1).set (j + 1) repaired.2.2)) =
keyBag (node ks cs) := by
dsimp only
have hbalance :=
replaceAdjacent_keyBag_balance
(newSep := (rotateRight left sep right).2.1)
(newLeft := (rotateRight left sep right).1)
(newRight := (rotateRight left sep right).2.2)
hsep hleft hright
have hrotation := rotateRight_keyBag left sep right
apply add_right_cancel
(b := keyBag left + {sep} + keyBag right)
calc
keyBag
(node (ks.set j (rotateRight left sep right).2.1)
((cs.set j (rotateRight left sep right).1).set
(j + 1) (rotateRight left sep right).2.2)) +
(keyBag left + {sep} + keyBag right) =
keyBag (node ks cs) +
(keyBag (rotateRight left sep right).1 +
{(rotateRight left sep right).2.1} +
keyBag (rotateRight left sep right).2.2) :=
hbalance
_ = keyBag (node ks cs) +
(keyBag left + {sep} + keyBag right) := by
rw [hrotation]A left rotation preserves the complete parent key bag.
theorem rotateLeft_parent_keyBag
{j sep : Nat} {ks : List Nat} {cs : List BTree}
{left right : BTree}
(hsep : ks[j]? = some sep)
(hleft : cs[j]? = some left)
(hright : cs[j + 1]? = some right) :
let repaired := rotateLeft left sep right
keyBag
(node (ks.set j repaired.2.1)
((cs.set j repaired.1).set (j + 1) repaired.2.2)) =
keyBag (node ks cs) := by
dsimp only
have hbalance :=
replaceAdjacent_keyBag_balance
(newSep := (rotateLeft left sep right).2.1)
(newLeft := (rotateLeft left sep right).1)
(newRight := (rotateLeft left sep right).2.2)
hsep hleft hright
have hrotation := rotateLeft_keyBag left sep right
apply add_right_cancel
(b := keyBag left + {sep} + keyBag right)
calc
keyBag
(node (ks.set j (rotateLeft left sep right).2.1)
((cs.set j (rotateLeft left sep right).1).set
(j + 1) (rotateLeft left sep right).2.2)) +
(keyBag left + {sep} + keyBag right) =
keyBag (node ks cs) +
(keyBag (rotateLeft left sep right).1 +
{(rotateLeft left sep right).2.1} +
keyBag (rotateLeft left sep right).2.2) :=
hbalance
_ = keyBag (node ks cs) +
(keyBag left + {sep} + keyBag right) := by
rw [hrotation]After borrowing from the right, deleting a routed key recursively from the repaired left child removes exactly one occurrence from the parent.
theorem rotateRight_reassembly_keyBag_erase
{j sep x : Nat} {ks : List Nat} {cs : List BTree}
{left right left' : BTree}
(hsep : ks[j]? = some sep)
(hleft : cs[j]? = some left)
(hright : cs[j + 1]? = some right)
(hroute :
x ∈ keysOf (node ks cs) → x ∈ keysOf left)
(hrec :
keyBag left' =
(keyBag (rotateRight left sep right).1).erase x) :
let repaired := rotateRight left sep right
keyBag
(node (ks.set j repaired.2.1)
((cs.set j left').set (j + 1) repaired.2.2)) =
(keyBag (node ks cs)).erase x := by
dsimp only
have hrotated :=
rotateRight_parent_keyBag hsep hleft hright
dsimp only at hrotated
obtain ⟨hj, _⟩ := List.getElem?_eq_some_iff.mp hleft
have htargetAt :
((cs.set j (rotateRight left sep right).1).set
(j + 1) (rotateRight left sep right).2.2)[j]? =
some (rotateRight left sep right).1 := by
rw [List.getElem?_set_ne (by omega : j + 1 ≠ j),
List.getElem?_set_eq_of_lt _ hj]
have htargetRoute :
x ∈ keysOf
(node (ks.set j (rotateRight left sep right).2.1)
((cs.set j (rotateRight left sep right).1).set
(j + 1) (rotateRight left sep right).2.2)) →
x ∈ keysOf (rotateRight left sep right).1 := by
intro hx
have hxBag :
x ∈ keyBag
(node (ks.set j (rotateRight left sep right).2.1)
((cs.set j (rotateRight left sep right).1).set
(j + 1) (rotateRight left sep right).2.2)) := by
simpa only [keyBag, Multiset.mem_coe] using hx
rw [hrotated] at hxBag
have hxOriginal : x ∈ keysOf (node ks cs) := by
simpa only [keyBag, Multiset.mem_coe] using hxBag
exact
mem_rotateRight_left_of_mem_left left sep right
(hroute hxOriginal)
have hfinal :=
replaceChild_keyBag_erase htargetAt htargetRoute hrec
have hchildren :
(((cs.set j (rotateRight left sep right).1).set
(j + 1) (rotateRight left sep right).2.2).set j left') =
(cs.set j left').set
(j + 1) (rotateRight left sep right).2.2 := by
rw [List.set_comm _ _ (by omega : j + 1 ≠ j), List.set_set]
rw [hchildren, hrotated] at hfinal
exact hfinalAfter borrowing from the left, deleting a routed key recursively from the repaired right child removes exactly one occurrence from the parent.
theorem rotateLeft_reassembly_keyBag_erase
{j sep x : Nat} {ks : List Nat} {cs : List BTree}
{left right right' : BTree}
(hsep : ks[j]? = some sep)
(hleft : cs[j]? = some left)
(hright : cs[j + 1]? = some right)
(hroute :
x ∈ keysOf (node ks cs) → x ∈ keysOf right)
(hrec :
keyBag right' =
(keyBag (rotateLeft left sep right).2.2).erase x) :
let repaired := rotateLeft left sep right
keyBag
(node (ks.set j repaired.2.1)
((cs.set j repaired.1).set (j + 1) right')) =
(keyBag (node ks cs)).erase x := by
dsimp only
have hrotated :=
rotateLeft_parent_keyBag hsep hleft hright
dsimp only at hrotated
obtain ⟨hjRight, _⟩ :=
List.getElem?_eq_some_iff.mp hright
have htargetAt :
((cs.set j (rotateLeft left sep right).1).set
(j + 1) (rotateLeft left sep right).2.2)[j + 1]? =
some (rotateLeft left sep right).2.2 :=
List.getElem?_set_eq_of_lt _ (by simpa using hjRight)
have htargetRoute :
x ∈ keysOf
(node (ks.set j (rotateLeft left sep right).2.1)
((cs.set j (rotateLeft left sep right).1).set
(j + 1) (rotateLeft left sep right).2.2)) →
x ∈ keysOf (rotateLeft left sep right).2.2 := by
intro hx
have hxBag :
x ∈ keyBag
(node (ks.set j (rotateLeft left sep right).2.1)
((cs.set j (rotateLeft left sep right).1).set
(j + 1) (rotateLeft left sep right).2.2)) := by
simpa only [keyBag, Multiset.mem_coe] using hx
rw [hrotated] at hxBag
have hxOriginal : x ∈ keysOf (node ks cs) := by
simpa only [keyBag, Multiset.mem_coe] using hxBag
exact
mem_rotateLeft_right_of_mem_right left sep right
(hroute hxOriginal)
have hfinal :=
replaceChild_keyBag_erase htargetAt htargetRoute hrec
simpa only [List.set_set, hrotated] using hfinalend BTreeend Chapter18end CLRSCLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.Invariant
Invariant contracts for composed B-tree deletion
This module records the invariant packet required by recursive deletion and
the one-step normalization used after deleting from the root. The raw
composedDelete operation may temporarily produce an empty root with one
child; normalizeRoot contracts exactly that shape.
namespace CLRSnamespace Chapter18namespace BTreeBundled deletion contracts
The four structural invariants required at a node during deletion.
def NodeWF (t : Nat) (isRoot : Bool) (tr : BTree) : Prop :=
Sorted tr ∧ ChildBounded tr ∧ Occupancy t isRoot tr ∧ SameDepth tr
The entry guard for deletion: roots are always ready, while non-root nodes
must contain at least t keys before recursive descent.
Every key represented after an operation was represented before it.
The structural result permitted from raw root deletion. It is either an
ordinary occupied root or the single-child empty-root transient contracted by
normalizeRoot.
def RootDeleteResult (t : Nat) (tr : BTree) : Prop :=
Sorted tr ∧ ChildBounded tr ∧ SameDepth tr ∧
(Occupancy t true tr ∨
∃ child, tr = node [] [child] ∧ Occupancy t false child)namespace NodeWFProject sortedness from the deletion invariant packet.
Project child bounds from the deletion invariant packet.
theorem childBounded {t : Nat} {isRoot : Bool} {tr : BTree}
(h : NodeWF t isRoot tr) : ChildBounded tr :=
h.2.1Project occupancy from the deletion invariant packet.
theorem occupancy {t : Nat} {isRoot : Bool} {tr : BTree}
(h : NodeWF t isRoot tr) : Occupancy t isRoot tr :=
h.2.2.1Project equal leaf depth from the deletion invariant packet.
theorem sameDepth {t : Nat} {isRoot : Bool} {tr : BTree}
(h : NodeWF t isRoot tr) : SameDepth tr :=
h.2.2.2end NodeWFnamespace WellFormedA well-formed tree is the root-specialized deletion invariant packet.
theorem nodeWF {t : Nat} {tr : BTree}
(h : WellFormed t tr) : NodeWF t true tr :=
hend WellFormedRoot calls always satisfy the deletion-entry guard.
theorem deleteReady_root (t : Nat) (tr : BTree) :
DeleteReady t true tr := by
simp [DeleteReady]
At a non-root node, readiness is exactly the CLRS t-key guard.
theorem deleteReady_nonRoot_iff (t : Nat) (tr : BTree) :
DeleteReady t false tr ↔ t ≤ numKeys tr := by
simp [DeleteReady]Non-root occupancy implies root occupancy when the minimum degree is at least two.
theorem occupancy_true_of_false {t : Nat} {tr : BTree}
(ht : 2 ≤ t) (h : Occupancy t false tr) :
Occupancy t true tr := by
rcases tr with ⟨ks, cs⟩
unfold Occupancy at h ⊢
simp only [Bool.false_eq_true, ↓reduceIte] at h
obtain ⟨hlower, hupper, hchildren, hrec⟩ := h
have hkeys : 1 ≤ ks.length := by omega
have hchildrenRoot :
cs.isEmpty ∨ (2 ≤ cs.length ∧ cs.length ≤ 2 * t) := by
rcases hchildren with hleaf | ⟨hlowerChildren, hupperChildren⟩
· exact Or.inl hleaf
· exact Or.inr ⟨by omega, hupperChildren⟩
simp only [↓reduceIte]
refine ⟨?_, hupper, hchildrenRoot, hrec⟩
by_cases hempty : ks = [] ∧ cs = []
· simp [hempty]
· simpa [hempty] using hkeysEvery bundled invariant packet can be viewed through the weaker root occupancy contract when the minimum degree is at least two.
theorem NodeWF.asRoot {t : Nat} {isRoot : Bool} {tr : BTree}
(h : NodeWF t isRoot tr) (ht : 2 ≤ t) :
NodeWF t true tr := by
cases isRoot with
| false =>
exact
⟨h.sorted, h.childBounded,
occupancy_true_of_false ht h.occupancy, h.sameDepth⟩
| true =>
simpa using hRoot normalization
Contract an empty root with exactly one child; leave every other tree unchanged.
Run raw composed deletion and then contract its possible empty root.
def composedDeleteRoot (t x : Nat) (tr : BTree) : BTree :=
normalizeRoot (composedDelete t x tr)Root normalization preserves the represented key list exactly.
theorem keysOf_normalizeRoot (tr : BTree) :
keysOf (normalizeRoot tr) = keysOf tr := by
rcases tr with ⟨ks, cs⟩
cases ks with
| nil =>
cases cs with
| nil => rfl
| cons child rest =>
cases rest with
| nil => simp [normalizeRoot, keysOf]
| cons child₂ rest => rfl
| cons k ks => rflRoot normalization either preserves height or removes exactly the old root level.
theorem heightOf_normalizeRoot (tr : BTree) :
heightOf (normalizeRoot tr) = heightOf tr ∨
heightOf (normalizeRoot tr) + 1 = heightOf tr := by
rcases tr with ⟨ks, cs⟩
cases ks with
| nil =>
cases cs with
| nil => exact Or.inl rfl
| cons child rest =>
cases rest with
| nil =>
right
simp [normalizeRoot, heightOf, Nat.add_comm]
| cons child₂ rest => exact Or.inl rfl
| cons k ks => exact Or.inl rflprivate theorem normalizeRoot_eq_self_of_occupancy_true
{t : Nat} {tr : BTree} (h : Occupancy t true tr) :
normalizeRoot tr = tr := by
rcases tr with ⟨ks, cs⟩
cases ks with
| nil =>
cases cs with
| nil => rfl
| cons child rest =>
cases rest with
| nil => simp [Occupancy] at h
| cons child₂ rest => rfl
| cons k ks => rflNormalizing either allowed raw-root result produces a genuinely well-formed B-tree root.
theorem normalizeRoot_wellFormed {t : Nat} {tr : BTree}
(ht : 2 ≤ t) (h : RootDeleteResult t tr) :
WellFormed t (normalizeRoot tr) := by
obtain ⟨hsorted, hbounded, hdepth, hroot⟩ := h
rcases hroot with hoccupancy | ⟨child, htr, hchildOccupancy⟩
· rw [normalizeRoot_eq_self_of_occupancy_true hoccupancy]
exact ⟨hsorted, hbounded, hoccupancy, hdepth⟩
· subst tr
unfold Sorted at hsorted
unfold ChildBounded at hbounded
have hchildSorted : Sorted child :=
hsorted.2 child (by simp)
have hchildBounded : ChildBounded child :=
hbounded.2.2 child (by simp)
have hchildDepth : SameDepth child :=
sameDepth_children_sd hdepth child (by simp)
change WellFormed t child
exact ⟨hchildSorted, hchildBounded,
occupancy_true_of_false ht hchildOccupancy, hchildDepth⟩Recursive-descent lookup and guard helpers
Every strict in-range list index has a concrete getElem? witness.
theorem getElem?_exists_of_lt {α : Type*} {xs : List α} {i : Nat}
(hi : i < xs.length) :
∃ a, xs[i]? = some a :=
⟨xs[i], List.getElem?_eq_getElem hi⟩A positive index bounded by the list length has an in-range predecessor.
theorem getElem?_pred_exists {α : Type*} {xs : List α} {i : Nat}
(hpos : 0 < i) (hi : i ≤ xs.length) :
∃ a, xs[i - 1]? = some a :=
getElem?_exists_of_lt (by omega)If an indexed list element exists and its index is positive, its immediate left sibling exists.
theorem getElem?_leftSibling_exists {α : Type*} {xs : List α} {i : Nat} {a : α}
(hcurrent : xs[i]? = some a) (hpos : 0 < i) :
∃ left, xs[i - 1]? = some left := by
have hi : i < xs.length := (List.getElem?_eq_some_iff.mp hcurrent).1
exact getElem?_pred_exists hpos (Nat.le_of_lt hi)If index plus one is below the list length, the immediate right sibling exists.
theorem getElem?_rightSibling_exists {α : Type*} {xs : List α} {i : Nat}
(hi : i + 1 < xs.length) :
∃ right, xs[i + 1]? = some right :=
getElem?_exists_of_lt hiA positive child-search index always has a concrete separator immediately before it.
theorem findChild_predecessor_exists {ks : List Nat} {x : Nat}
(hpos : 0 < findChild ks x) :
∃ sep, ks[findChild ks x - 1]? = some sep :=
getElem?_pred_exists hpos (findChild_le ks x)
The predecessor-separator fallback of composedDelete is unreachable
at a positive child-search index.
theorem findChild_predecessor_none_absurd {ks : List Nat} {x : Nat}
(hpos : 0 < findChild ks x)
(hnone : ks[findChild ks x - 1]? = none) :
False := by
obtain ⟨sep, hsep⟩ := findChild_predecessor_exists hpos
rw [hnone] at hsep
simp at hsepnamespace NodeWFEvery child of a node satisfying the bundled invariant packet satisfies the same packet as a non-root node.
theorem child {t : Nat} {isRoot : Bool} {ks : List Nat} {cs : List BTree}
{child : BTree} (h : NodeWF t isRoot (node ks cs)) (hchild : child ∈ cs) :
NodeWF t false child := by
have hsorted := h.sorted
have hbounded := h.childBounded
have hoccupancy := h.occupancy
unfold Sorted at hsorted
unfold ChildBounded at hbounded
unfold Occupancy at hoccupancy
refine ⟨hsorted.2 child hchild, hbounded.2.2 child hchild,
hoccupancy.2.2.2 child hchild, ?_⟩
exact sameDepth_children_sd h.sameDepth child hchildAn occupied, nonempty bundled node has at least one key at every descendant when the minimum degree is at least two.
theorem allKeysPos {t : Nat} {isRoot : Bool} {tr : BTree}
(h : NodeWF t isRoot tr) (ht : 2 ≤ t) (hne : 0 < numKeys tr) :
AllKeysPos tr :=
allKeysPos_of_occupancy t ht tr isRoot h.occupancy hneA non-root bundled node automatically has at least one key at every descendant when the minimum degree is at least two.
theorem nonRoot_allKeysPos {t : Nat} {tr : BTree}
(h : NodeWF t false tr) (ht : 2 ≤ t) : AllKeysPos tr := by
apply h.allKeysPos ht
rcases tr with ⟨ks, cs⟩
have hlower : t - 1 ≤ ks.length := (occupancy_false_dest h.occupancy).1
show 0 < ks.length
omegaThe children of a bundled node are either absent or number exactly one more than its keys.
theorem children_rel {t : Nat} {isRoot : Bool} {ks : List Nat} {cs : List BTree}
(h : NodeWF t isRoot (node ks cs)) :
cs = [] ∨ cs.length = ks.length + 1 :=
childBounded_children_rel h.childBounded
On an internal bundled node, findChild always selects an in-range child.
theorem findChild_lt {t : Nat} {isRoot : Bool} {ks : List Nat} {cs : List BTree}
(h : NodeWF t isRoot (node ks cs)) (hchildren : cs ≠ []) (x : Nat) :
findChild ks x < cs.length := by
have hlength : cs.length = ks.length + 1 :=
h.children_rel.resolve_left hchildren
have hfind : findChild ks x ≤ ks.length := findChild_le ks x
omega
On an internal bundled node, the child selected by findChild has a
concrete getElem? witness.
theorem findChild_exists
{t : Nat} {isRoot : Bool} {ks : List Nat} {cs : List BTree}
(h : NodeWF t isRoot (node ks cs)) (hchildren : cs ≠ []) (x : Nat) :
∃ child, cs[findChild ks x]? = some child :=
getElem?_exists_of_lt (h.findChild_lt hchildren x)The missing-current-child fallback is unreachable in an internal bundled node.
theorem findChild_none_absurd
{t : Nat} {isRoot : Bool} {ks : List Nat} {cs : List BTree}
(h : NodeWF t isRoot (node ks cs)) (hchildren : cs ≠ [])
{x : Nat} (hnone : cs[findChild ks x]? = none) :
False := by
obtain ⟨child, hchild⟩ := h.findChild_exists hchildren x
rw [hnone] at hchild
simp at hchildAt a positive child-search index, the missing-left-sibling fallback is unreachable in an internal bundled node.
theorem findChild_leftSibling_none_absurd
{t : Nat} {isRoot : Bool} {ks : List Nat} {cs : List BTree}
(h : NodeWF t isRoot (node ks cs)) (hchildren : cs ≠ [])
{x : Nat} (hpos : 0 < findChild ks x)
(hnone : cs[findChild ks x - 1]? = none) :
False := by
have hcurrentLt := h.findChild_lt hchildren x
obtain ⟨left, hleft⟩ :=
getElem?_pred_exists hpos (Nat.le_of_lt hcurrentLt)
rw [hnone] at hleft
simp at hleftEvery nonempty child list in a bundled node has at least two entries when the minimum degree is at least two. This is the root/non-root common form needed by the right-sibling branch at child index zero.
theorem two_le_children_of_not_empty
{t : Nat} {isRoot : Bool} {ks : List Nat} {cs : List BTree}
(h : NodeWF t isRoot (node ks cs)) (ht : 2 ≤ t)
(hchildren : cs ≠ []) :
2 ≤ cs.length := by
have hoccupancy := h.occupancy
unfold Occupancy at hoccupancy
cases isRoot with
| false =>
simp only [Bool.false_eq_true, ↓reduceIte] at hoccupancy
rcases hoccupancy.2.2.1 with hempty | hbounds
· exact absurd (List.isEmpty_iff.mp hempty) hchildren
· omega
| true =>
simp only [↓reduceIte] at hoccupancy
rcases hoccupancy.2.2.1 with hempty | hbounds
· exact absurd (List.isEmpty_iff.mp hempty) hchildren
· exact hbounds.1The right sibling of child zero exists in every internal bundled node.
theorem rightSibling_zero_exists
{t : Nat} {isRoot : Bool} {ks : List Nat} {cs : List BTree}
(h : NodeWF t isRoot (node ks cs)) (ht : 2 ≤ t)
(hchildren : cs ≠ []) :
∃ right, cs[1]? = some right :=
getElem?_exists_of_lt (h.two_le_children_of_not_empty ht hchildren)
Whenever child i + 1 exists, the separator immediately before it is
present in the parent key list.
theorem separator_before_rightSibling_exists
{t : Nat} {isRoot : Bool} {ks : List Nat} {cs : List BTree}
(h : NodeWF t isRoot (node ks cs)) (hchildren : cs ≠ [])
{i : Nat} {right : BTree} (hright : cs[i + 1]? = some right) :
∃ sep, ks[i]? = some sep := by
have hrightIndex : i + 1 < cs.length :=
(List.getElem?_eq_some_iff.mp hright).1
have hlength : cs.length = ks.length + 1 :=
h.children_rel.resolve_left hchildren
exact getElem?_exists_of_lt (by omega)The child to the left of a present separator key exists in every internal bundled node.
theorem leftChild_exists_of_key
{t : Nat} {isRoot : Bool} {ks : List Nat} {cs : List BTree}
{ki sep : Nat} (h : NodeWF t isRoot (node ks cs)) (hchildren : cs ≠ [])
(hkey : ks[ki]? = some sep) :
∃ child, cs[ki]? = some child := by
have hki : ki < ks.length := (List.getElem?_eq_some_iff.mp hkey).1
have hlength : cs.length = ks.length + 1 :=
h.children_rel.resolve_left hchildren
exact getElem?_exists_of_lt (by omega)The child to the right of a present separator key exists in every internal bundled node; the right child is at separator index plus one.
theorem rightChild_exists_of_key
{t : Nat} {isRoot : Bool} {ks : List Nat} {cs : List BTree}
{ki sep : Nat} (h : NodeWF t isRoot (node ks cs)) (hchildren : cs ≠ [])
(hkey : ks[ki]? = some sep) :
∃ child, cs[ki + 1]? = some child := by
have hki : ki < ks.length := (List.getElem?_eq_some_iff.mp hkey).1
have hlength : cs.length = ks.length + 1 :=
h.children_rel.resolve_left hchildren
exact getElem?_exists_of_lt (by omega)Any two children of a bundled node have the same height.
theorem siblings_height
{t : Nat} {isRoot : Bool} {ks : List Nat} {cs : List BTree}
(h : NodeWF t isRoot (node ks cs)) {left right : BTree}
(hleft : left ∈ cs) (hright : right ∈ cs) :
heightOf left = heightOf right :=
(sameDepth_iff.mp h.sameDepth).2 left hleft right hrightProject the complete local facts for two children adjacent to a present separator: both child packets, equal height, and the two separator key bounds.
theorem adjacent_children
{t j sep : Nat} {isRoot : Bool}
{ks : List Nat} {cs : List BTree} {left right : BTree}
(h : NodeWF t isRoot (node ks cs))
(hsep : ks[j]? = some sep)
(hleft : cs[j]? = some left)
(hright : cs[j + 1]? = some right) :
NodeWF t false left ∧ NodeWF t false right ∧
heightOf left = heightOf right ∧
(∀ k ∈ keysOf left, k ≤ sep) ∧
(∀ k ∈ keysOf right, sep ≤ k) := by
obtain ⟨hjLeft, hleftGetElem⟩ :=
List.getElem?_eq_some_iff.mp hleft
obtain ⟨hjRight, hrightGetElem⟩ :=
List.getElem?_eq_some_iff.mp hright
have hleftGet : cs.get ⟨j, hjLeft⟩ = left := by
rw [List.get_eq_getElem]
exact hleftGetElem
have hrightGet : cs.get ⟨j + 1, hjRight⟩ = right := by
rw [List.get_eq_getElem]
exact hrightGetElem
have hleftMem : left ∈ cs :=
List.mem_iff_getElem?.mpr ⟨j, hleft⟩
have hrightMem : right ∈ cs :=
List.mem_iff_getElem?.mpr ⟨j + 1, hright⟩
have hbounds := h.childBounded
unfold ChildBounded at hbounds
have hleftBounds := hbounds.2.1 j hjLeft
rw [hleftGet, hsep] at hleftBounds
have hrightBounds := hbounds.2.1 (j + 1) hjRight
rw [hrightGet] at hrightBounds
have hrightLower : ∀ k ∈ keysOf right, sep ≤ k := by
rcases hrightBounds.1 with hzero | hlower
· omega
· rw [show j + 1 - 1 = j by omega, hsep] at hlower
exact hlower
exact
⟨h.child hleftMem, h.child hrightMem,
h.siblings_height hleftMem hrightMem,
hleftBounds.2, hrightLower⟩end NodeWF
A non-ready occupied non-root node has exactly the minimum t - 1 keys.
theorem numKeys_eq_t_sub_one_of_not_ready
{t : Nat} {tr : BTree} (hoccupancy : Occupancy t false tr)
(hnotReady : ¬ t ≤ numKeys tr) :
numKeys tr = t - 1 := by
rcases tr with ⟨ks, cs⟩
have hlower : t - 1 ≤ ks.length := (occupancy_false_dest hoccupancy).1
change ¬ t ≤ ks.length at hnotReady
change ks.length = t - 1
omeganamespace KeysSubsetEvery tree's represented keys are a subset of themselves.
theorem refl (tr : BTree) : KeysSubset tr tr := by
intro k hk
exact hkKey containment composes through an intermediate tree.
theorem trans {after middle before : BTree}
(h₁ : KeysSubset after middle) (h₂ : KeysSubset middle before) :
KeysSubset after before := by
intro k hk
exact h₂ k (h₁ k hk)end KeysSubsetend BTreeend Chapter18end CLRSCLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.KeyMultiset
Exact key multisets for B-tree deletion
Executable B-tree deletion removes one occurrence of a key, whereas the specification-level deletion operation filters every occurrence. This module records represented keys as a multiset and proves the exact conservation equations for the primitive deletion operations.
The generic frame-balance lemmas expose the list accounting needed by parent reassembly without depending on any B-tree structural invariant.
namespace CLRSnamespace Chapter18namespace BTreeThe represented keys of a B-tree, retaining multiplicity and ignoring order.
private theorem coe_append_eq_add {α : Type*} (xs ys : List α) :
(↑(xs ++ ys) : Multiset α) = ↑xs + ↑ys :=
(Multiset.coe_add xs ys).symm
private theorem coe_cons_eq_singleton_add {α : Type*} (x : α) (xs : List α) :
(↑(x :: xs) : Multiset α) = {x} + ↑xs := by
rw [Multiset.singleton_add, Multiset.cons_coe]Replacing a witnessed list element balances the new and old list bags against the removed and inserted elements.
theorem list_set_bag_balance
{α : Type*} {xs : List α} {i : Nat} {old new : α}
(hold : xs[i]? = some old) :
(↑(xs.set i new) : Multiset α) + {old} =
(↑xs : Multiset α) + {new} := by
obtain ⟨hi, hget⟩ := List.getElem?_eq_some_iff.mp hold
have hset :
(↑(xs.set i new) : Multiset α) =
↑(new :: xs.eraseIdx i) :=
Multiset.coe_eq_coe.mpr (List.set_perm_cons_eraseIdx hi new)
have holdSource :
(↑(old :: xs.eraseIdx i) : Multiset α) = ↑xs := by
apply Multiset.coe_eq_coe.mpr
simpa only [hget] using List.getElem_cons_eraseIdx_perm hi
rw [hset, ← holdSource]
simp only [coe_cons_eq_singleton_add]
abel
Replacing a witnessed element before List.flatMap balances the
flattened bags of the old and new elements.
theorem flatMap_set_bag_balance
{α β : Type*} {xs : List α} {i : Nat} {old new : α}
(f : α → List β)
(hold : xs[i]? = some old) :
(↑((xs.set i new).flatMap f) : Multiset β) + ↑(f old) =
(↑(xs.flatMap f) : Multiset β) + ↑(f new) := by
obtain ⟨hi, hget⟩ := List.getElem?_eq_some_iff.mp hold
have hsetPerm :
((xs.set i new).flatMap f).Perm
((new :: xs.eraseIdx i).flatMap f) :=
(List.set_perm_cons_eraseIdx hi new).flatMap
(fun _ _ => List.Perm.refl _)
have holdPerm :
((old :: xs.eraseIdx i).flatMap f).Perm
(xs.flatMap f) := by
have hsource := List.getElem_cons_eraseIdx_perm hi
have hsource' : (old :: xs.eraseIdx i).Perm xs := by
simpa only [hget] using hsource
exact hsource'.flatMap (fun _ _ => List.Perm.refl _)
have hsetBag :
(↑((xs.set i new).flatMap f) : Multiset β) =
↑((new :: xs.eraseIdx i).flatMap f) :=
Multiset.coe_eq_coe.mpr hsetPerm
have holdBag :
(↑((old :: xs.eraseIdx i).flatMap f) : Multiset β) =
↑(xs.flatMap f) :=
Multiset.coe_eq_coe.mpr holdPerm
rw [hsetBag, ← holdBag]
simp only [List.flatMap_cons, coe_append_eq_add]
abelRemoving one witnessed list position and retaining its value preserves the bag.
theorem take_drop_succ_bag_balance
{α : Type*} {xs : List α} {j : Nat} {old : α}
(hold : xs[j]? = some old) :
(↑(xs.take j ++ xs.drop (j + 1)) : Multiset α) + {old} =
(↑xs : Multiset α) := by
obtain ⟨hj, hget⟩ := List.getElem?_eq_some_iff.mp hold
rw [← List.eraseIdx_eq_take_drop_succ]
have hsource :
(↑(old :: xs.eraseIdx j) : Multiset α) = ↑xs := by
apply Multiset.coe_eq_coe.mpr
simpa only [hget] using List.getElem_cons_eraseIdx_perm hj
simpa only [coe_cons_eq_singleton_add, add_comm] using hsource
Replacing two witnessed adjacent elements by one element preserves the
corresponding List.flatMap bag balance.
theorem flatMap_splice_bag_balance
{α β : Type*} {xs : List α} {j : Nat}
{left right new : α}
(f : α → List β)
(hleft : xs[j]? = some left)
(hright : xs[j + 1]? = some right) :
(↑((xs.take j ++ [new] ++ xs.drop (j + 2)).flatMap f) :
Multiset β) +
↑(f left) + ↑(f right) =
(↑(xs.flatMap f) : Multiset β) + ↑(f new) := by
obtain ⟨hj, hleftGet⟩ := List.getElem?_eq_some_iff.mp hleft
obtain ⟨hjRight, hrightGet⟩ :=
List.getElem?_eq_some_iff.mp hright
have hdecomp :
xs.take j ++ left :: right :: xs.drop (j + 2) = xs := by
calc
xs.take j ++ left :: right :: xs.drop (j + 2) =
xs.take j ++ xs.drop j := by
congr 1
rw [List.drop_eq_getElem_cons hj, hleftGet]
rw [List.drop_eq_getElem_cons hjRight, hrightGet]
_ = xs := List.take_append_drop j xs
have hsource :
(↑((xs.take j ++ left :: right :: xs.drop (j + 2)).flatMap f) :
Multiset β) =
↑(xs.flatMap f) := by
exact congrArg (fun ys : List α =>
(↑(ys.flatMap f) : Multiset β)) hdecomp
rw [← hsource]
simp only [List.flatMap_append, List.flatMap_cons, List.flatMap_nil,
List.append_nil, coe_append_eq_add]
abelA recursive erase equation lifts through a balanced frame when membership of the deleted key in the pre-update frame implies membership in the recursive subtree.
theorem keyBag_erase_of_balance
{after before old new : Multiset Nat} {x : Nat}
(hbalance : after + old = before + new)
(hnew : new = old.erase x)
(hroute : x ∈ before → x ∈ old) :
after = before.erase x := by
by_cases hxBefore : x ∈ before
· have hxOld : x ∈ old := hroute hxBefore
have hwithCons :
after + (x ::ₘ old.erase x) =
(x ::ₘ before.erase x) + old.erase x := by
calc
after + (x ::ₘ old.erase x) = after + old := by
rw [Multiset.cons_erase hxOld]
_ = before + new := hbalance
_ = before + old.erase x := by rw [hnew]
_ = (x ::ₘ before.erase x) + old.erase x := by
rw [Multiset.cons_erase hxBefore]
have hcancelX :
({x} : Multiset Nat) + (after + old.erase x) =
{x} + (before.erase x + old.erase x) := by
calc
({x} : Multiset Nat) + (after + old.erase x) =
after + (x ::ₘ old.erase x) := by
rw [← Multiset.singleton_add]
ac_rfl
_ = (x ::ₘ before.erase x) + old.erase x := hwithCons
_ = {x} + (before.erase x + old.erase x) := by
rw [← Multiset.singleton_add]
ac_rfl
exact add_right_cancel (add_left_cancel hcancelX)
· have hxOld : x ∉ old := by
intro hxOld
have hwithCons :
({x} : Multiset Nat) + after + old.erase x =
before + old.erase x := by
calc
({x} : Multiset Nat) + after + old.erase x =
after + (x ::ₘ old.erase x) := by
rw [← Multiset.singleton_add]
ac_rfl
_ = after + old := by rw [Multiset.cons_erase hxOld]
_ = before + new := hbalance
_ = before + old.erase x := by rw [hnew]
have hmemBefore : x ∈ before := by
have hsingle : ({x} : Multiset Nat) + after = before :=
add_right_cancel hwithCons
rw [← hsingle]
simp
exact hxBefore hmemBefore
have hnewEq : new = old := by
rw [hnew, Multiset.erase_of_notMem hxOld]
have hsame : after = before := by
apply add_right_cancel (b := old)
calc
after + old = before + new := hbalance
_ = before + old := by rw [hnewEq]
rw [Multiset.erase_of_notMem hxBefore]
exact hsame
sortedRemove erases exactly the first matching list occurrence.
theorem sortedRemove_keyBag (x : Nat) (ks : List Nat) :
(↑(sortedRemove x ks) : Multiset Nat) =
(↑ks : Multiset Nat).erase x := by
induction ks with
| nil => simp [sortedRemove]
| cons k ks ih =>
rw [sortedRemove_cons]
split
next _ =>
subst k
simp
next h =>
rw [← Multiset.cons_coe, ← Multiset.cons_coe,
Multiset.erase_cons_tail _ h, ih]Merging two nodes around a separator preserves their combined key bag.
theorem mergeNodes_keyBag (left : BTree) (sep : Nat) (right : BTree) :
keyBag (mergeNodes left sep right) =
keyBag left + {sep} + keyBag right := by
cases left with
| node lKeys lCh =>
cases right with
| node rKeys rCh =>
simp only [keyBag, mergeNodes_node, keysOf, List.flatMap_append]
simp only [coe_append_eq_add, coe_cons_eq_singleton_add]
abelBorrowing from the right sibling preserves the three-part key bag.
theorem rotateRight_keyBag (left : BTree) (sep : Nat) (right : BTree) :
keyBag (rotateRight left sep right).1 +
{(rotateRight left sep right).2.1} +
keyBag (rotateRight left sep right).2.2 =
keyBag left + {sep} + keyBag right := by
cases left with
| node lKeys lCh =>
cases right with
| node rKeys rCh =>
cases rKeys with
| nil => rfl
| cons rHead rTail =>
cases rCh with
| nil =>
simp only [rotateRight_cons, keyBag, keysOf, List.append_nil,
List.take_nil, List.drop_nil, List.flatMap_nil]
simp only [coe_append_eq_add, coe_cons_eq_singleton_add,
Multiset.coe_nil, add_zero]
abel
| cons child children =>
simp only [rotateRight_cons, keyBag, keysOf,
List.take_succ_cons, List.take_zero,
List.drop_succ_cons, List.drop_zero,
List.flatMap_append, List.flatMap_cons, List.flatMap_nil,
List.append_nil]
simp only [coe_append_eq_add, coe_cons_eq_singleton_add,
Multiset.coe_nil, add_zero]
abelBorrowing from the left sibling preserves the three-part key bag.
theorem rotateLeft_keyBag (left : BTree) (sep : Nat) (right : BTree) :
keyBag (rotateLeft left sep right).1 +
{(rotateLeft left sep right).2.1} +
keyBag (rotateLeft left sep right).2.2 =
keyBag left + {sep} + keyBag right := by
cases left with
| node lKeys lCh =>
cases right with
| node rKeys rCh =>
cases lKeys with
| nil => rfl
| cons lHead lTail =>
have hKeys :
(lHead :: lTail).dropLast ++
[(lHead :: lTail).getLast (List.cons_ne_nil _ _)] =
lHead :: lTail :=
List.dropLast_append_getLast (List.cons_ne_nil _ _)
have hChildren :
lCh.take (lCh.length - 1) ++
lCh.drop (lCh.length - 1) =
lCh :=
List.take_append_drop (lCh.length - 1) lCh
have hKeyBag :
(↑(lHead :: lTail).dropLast : Multiset Nat) +
{(lHead :: lTail).getLast (List.cons_ne_nil _ _)} =
(↑(lHead :: lTail) : Multiset Nat) := by
simpa only [coe_append_eq_add,
coe_cons_eq_singleton_add, Multiset.coe_nil, add_zero] using
congrArg (fun xs : List Nat =>
(↑xs : Multiset Nat)) hKeys
have hChildBag :
(↑((lCh.take (lCh.length - 1)).flatMap keysOf) :
Multiset Nat) +
↑((lCh.drop (lCh.length - 1)).flatMap keysOf) =
↑(lCh.flatMap keysOf) := by
simpa only [List.flatMap_append, coe_append_eq_add] using
congrArg (fun xs : List BTree =>
(↑(xs.flatMap keysOf) : Multiset Nat)) hChildren
simp only [rotateLeft_cons, keyBag, keysOf,
List.flatMap_append]
simp only [coe_append_eq_add]
rw [coe_cons_eq_singleton_add sep rKeys]
rw [← hKeyBag, ← hChildBag]
abelend BTreeend Chapter18end CLRSCLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.MergeReassembly
Parent reassembly after merging adjacent B-tree children
The deletion algorithm has three syntactically different merge sites, but all
three remove separator j, replace children j and j + 1 by one recursive
result, and retain the surrounding parent context. This module packages that
single atomic reassembly step.
namespace CLRSnamespace Chapter18namespace BTree
private lemma spliceKeys_get_before {α : Type*}
{xs : List α} {j q : Nat}
(hj : j < xs.length) (hq : q < j) :
(xs.take j ++ xs.drop (j + 1))[q]? = xs[q]? := by
have htake : (xs.take j).length = j := by
simp [Nat.min_eq_left (Nat.le_of_lt hj)]
rw [List.getElem?_append_left (by omega)]
simp [hq]
private lemma spliceKeys_get_after {α : Type*}
{xs : List α} {j q : Nat}
(hj : j < xs.length) (hq : j ≤ q) :
(xs.take j ++ xs.drop (j + 1))[q]? = xs[q + 1]? := by
have htake : (xs.take j).length = j := by
simp [Nat.min_eq_left (Nat.le_of_lt hj)]
rw [List.getElem?_append_right (by omega), List.getElem?_drop]
rw [htake]
congr 1
omega
private lemma spliceChildren_get_before {α : Type*}
{xs : List α} {new : α} {j q : Nat}
(hj : j + 1 < xs.length) (hq : q < j) :
(xs.take j ++ [new] ++ xs.drop (j + 2))[q]? = xs[q]? := by
have htake : (xs.take j).length = j := by
simp [Nat.min_eq_left (by omega : j ≤ xs.length)]
rw [List.getElem?_append_left]
· rw [List.getElem?_append_left (by omega)]
simp [hq]
· simp [htake]
omega
private lemma spliceChildren_get_eq {α : Type*}
{xs : List α} {new : α} {j : Nat}
(hj : j + 1 < xs.length) :
(xs.take j ++ [new] ++ xs.drop (j + 2))[j]? = some new := by
have htake : (xs.take j).length = j := by
simp [Nat.min_eq_left (by omega : j ≤ xs.length)]
rw [List.getElem?_append_left]
· rw [List.getElem?_append_right]
· rw [htake]
simp
· omega
· simp [htake]
private lemma spliceChildren_get_after {α : Type*}
{xs : List α} {new : α} {j q : Nat}
(hj : j + 1 < xs.length) (hq : j < q) :
(xs.take j ++ [new] ++ xs.drop (j + 2))[q]? = xs[q + 1]? := by
have htake : (xs.take j).length = j := by
simp [Nat.min_eq_left (by omega : j ≤ xs.length)]
rw [List.getElem?_append_right]
· rw [List.getElem?_drop]
simp [htake]
congr 1
omega
· simp [htake]
omegaprivate lemma mem_of_mem_spliceChildren {α : Type*}
{xs : List α} {new child : α} {j : Nat}
(hchild : child ∈ xs.take j ++ [new] ++ xs.drop (j + 2)) :
child ∈ xs ∨ child = new := by
rcases List.mem_append.mp hchild with hfront | hsuffix
rcases List.mem_append.mp hfront with hprefix | hnew
· exact Or.inl (List.mem_of_mem_take hprefix)
· simp only [List.mem_singleton] at hnew
exact Or.inr hnew
· exact Or.inl (List.mem_of_mem_drop hsuffix)
Atomic parent reassembly for every merge branch of composedDelete.
Separator j and its adjacent children are replaced by one recursive result.
The result remains an ordinary well-formed non-root node, or (at a root) is
either an ordinary root or the single-child empty-root transient accepted by
RootDeleteResult.
theorem spliceMerged_packet
{t j sep : Nat} {b : Bool}
{ks : List Nat} {cs : List BTree}
{left right newMerged : BTree}
(hparent : NodeWF t b (node ks cs))
(hready : DeleteReady t b (node ks cs))
(hsep : ks[j]? = some sep)
(hleft : cs[j]? = some left)
(hright : cs[j + 1]? = some right)
(hnew : NodeWF t false newMerged)
(hheight :
heightOf newMerged = heightOf (mergeNodes left sep right))
(hsubset :
KeysSubset newMerged (mergeNodes left sep right)) :
let out :=
node (ks.take j ++ ks.drop (j + 1))
(cs.take j ++ [newMerged] ++ cs.drop (j + 2))
(if b then RootDeleteResult t out else NodeWF t false out) ∧
heightOf out = heightOf (node ks cs) ∧
KeysSubset out (node ks cs) := by
dsimp only
obtain ⟨hjKey, hsepGetElem⟩ :=
List.getElem?_eq_some_iff.mp hsep
obtain ⟨hjLeft, hleftGetElem⟩ :=
List.getElem?_eq_some_iff.mp hleft
obtain ⟨hjRight, hrightGetElem⟩ :=
List.getElem?_eq_some_iff.mp hright
have hleftGet : cs.get ⟨j, hjLeft⟩ = left := by
rw [List.get_eq_getElem]
exact hleftGetElem
have hrightGet : cs.get ⟨j + 1, hjRight⟩ = right := by
rw [List.get_eq_getElem]
exact hrightGetElem
have hleftMem : left ∈ cs :=
List.mem_iff_getElem?.mpr ⟨j, hleft⟩
have hrightMem : right ∈ cs :=
List.mem_iff_getElem?.mpr ⟨j + 1, hright⟩
have hleftWF : NodeWF t false left :=
hparent.child hleftMem
have hrightWF : NodeWF t false right :=
hparent.child hrightMem
have hsiblings : heightOf left = heightOf right :=
hparent.siblings_height hleftMem hrightMem
have hparentSorted := hparent.sorted
unfold Sorted at hparentSorted
have hparentBounded := hparent.childBounded
unfold ChildBounded at hparentBounded
obtain ⟨hchildrenRel, hbounds, hchildrenBounded⟩ :=
hparentBounded
have hcsLen : cs.length = ks.length + 1 := by
rcases hchildrenRel with hempty | hlength
· have : cs = [] := List.isEmpty_iff.mp hempty
subst cs
simp at hright
· exact hlength
have hleftBounds := hbounds j hjLeft
rw [hleftGet] at hleftBounds
have hrightBounds := hbounds (j + 1) hjRight
rw [hrightGet] at hrightBounds
have hleftLe : ∀ k ∈ keysOf left, k ≤ sep := by
have hupper := hleftBounds.2
rw [hsep] at hupper
exact hupper
have hrightGe : ∀ k ∈ keysOf right, sep ≤ k := by
rcases hrightBounds.1 with hzero | hlower
· omega
· rw [show j + 1 - 1 = j by omega, hsep] at hlower
exact hlower
have hmergedHeight :
heightOf (mergeNodes left sep right) = heightOf left :=
mergeNodes_height hleftWF.sameDepth hrightWF.sameDepth hsiblings
have hnewHeightLeft : heightOf newMerged = heightOf left :=
hheight.trans hmergedHeight
have hnewLower :
j = 0 ∨
(match ks[j - 1]? with
| some lower =>
∀ k ∈ keysOf newMerged, lower ≤ k
| none => True) := by
by_cases hjZero : j = 0
· exact Or.inl hjZero
· right
rcases hleftBounds.1 with hzero | hleftLower
· exact absurd hzero hjZero
· cases hprev : ks[j - 1]? with
| none => trivial
| some lower =>
rw [hprev] at hleftLower
have hjPred : j - 1 < ks.length := by omega
obtain ⟨_, hprevGetElem⟩ :=
List.getElem?_eq_some_iff.mp hprev
have hp :=
pairwise_get_mono hparentSorted.1
(by omega) hjPred hjKey
have hlowerSep : lower ≤ sep := by
simpa [hprevGetElem, hsepGetElem] using hp
intro k hk
have hkMerged := hsubset k hk
rw [mem_keysOf_mergeNodes] at hkMerged
rcases hkMerged with hkLeft | rfl | hkRight
· exact hleftLower k hkLeft
· exact hlowerSep
· exact hlowerSep.trans (hrightGe k hkRight)
have hnewUpper :
(match ks[j + 1]? with
| some upper =>
∀ k ∈ keysOf newMerged, k ≤ upper
| none => True) := by
cases hnext : ks[j + 1]? with
| none => trivial
| some upper =>
obtain ⟨hjNext, hnextGetElem⟩ :=
List.getElem?_eq_some_iff.mp hnext
have hp :=
pairwise_get_mono hparentSorted.1
(by omega) hjKey hjNext
have hsepUpper : sep ≤ upper := by
simpa [hsepGetElem, hnextGetElem] using hp
have hrightUpper := hrightBounds.2
rw [hnext] at hrightUpper
intro k hk
have hkMerged := hsubset k hk
rw [mem_keysOf_mergeNodes] at hkMerged
rcases hkMerged with hkLeft | rfl | hkRight
· exact (hleftLe k hkLeft).trans hsepUpper
· exact hsepUpper
· exact hrightUpper k hkRight
have hsorted :
Sorted
(node (ks.take j ++ ks.drop (j + 1))
(cs.take j ++ [newMerged] ++ cs.drop (j + 2))) := by
unfold Sorted
constructor
· rw [← List.eraseIdx_eq_take_drop_succ ks j]
exact hparentSorted.1.sublist (List.eraseIdx_sublist ks j)
· intro child hchild
rcases mem_of_mem_spliceChildren hchild with hchildOld | rfl
· exact hparentSorted.2 child hchildOld
· exact hnew.sorted
have hbounded :
ChildBounded
(node (ks.take j ++ ks.drop (j + 1))
(cs.take j ++ [newMerged] ++ cs.drop (j + 2))) := by
unfold ChildBounded
refine ⟨?_, ?_, ?_⟩
· right
simp only [List.length_append, List.length_take, List.length_drop,
List.length_cons, List.length_nil]
have hjLeKs : j ≤ ks.length := Nat.le_of_lt hjKey
have hjLeCs : j ≤ cs.length := by omega
omega
· intro q hq
let child :=
(cs.take j ++ [newMerged] ++ cs.drop (j + 2)).get ⟨q, hq⟩
have hchildGet :
(cs.take j ++ [newMerged] ++ cs.drop (j + 2))[q]? =
some child :=
List.getElem?_eq_getElem hq
change
(q = 0 ∨
(match
(ks.take j ++ ks.drop (j + 1))[q - 1]? with
| some lower => ∀ k ∈ keysOf child, lower ≤ k
| none => True)) ∧
(match (ks.take j ++ ks.drop (j + 1))[q]? with
| some upper => ∀ k ∈ keysOf child, k ≤ upper
| none => True)
by_cases hqBefore : q < j
· have hchildOldGet : cs[q]? = some child := by
rw [← spliceChildren_get_before hjRight hqBefore]
exact hchildGet
obtain ⟨hqOld, hchildOldGetElem⟩ :=
List.getElem?_eq_some_iff.mp hchildOldGet
have hold := hbounds q hqOld
have hchildEq : cs.get ⟨q, hqOld⟩ = child := by
rw [List.get_eq_getElem]
exact hchildOldGetElem
rw [hchildEq] at hold
constructor
· rcases hold.1 with hzero | hlower
· exact Or.inl hzero
· right
rw [spliceKeys_get_before hjKey (by omega)]
exact hlower
· rw [spliceKeys_get_before hjKey hqBefore]
exact hold.2
· by_cases hqEq : q = j
· subst q
have hchildEq : child = newMerged := by
rw [spliceChildren_get_eq hjRight] at hchildGet
exact Option.some.inj hchildGet.symm
rw [hchildEq]
constructor
· by_cases hjZero : j = 0
· exact Or.inl hjZero
· right
rw [spliceKeys_get_before hjKey (by omega)]
exact hnewLower.resolve_left hjZero
· rw [spliceKeys_get_after hjKey (Nat.le_refl j)]
exact hnewUpper
· have hqAfter : j < q := by omega
have hchildOldGet : cs[q + 1]? = some child := by
rw [← spliceChildren_get_after hjRight hqAfter]
exact hchildGet
obtain ⟨hqOld, hchildOldGetElem⟩ :=
List.getElem?_eq_some_iff.mp hchildOldGet
have hold := hbounds (q + 1) hqOld
have hchildEq : cs.get ⟨q + 1, hqOld⟩ = child := by
rw [List.get_eq_getElem]
exact hchildOldGetElem
rw [hchildEq] at hold
constructor
· right
rcases hold.1 with hzero | hlower
· omega
· rw [show q + 1 - 1 = q by omega] at hlower
rw [spliceKeys_get_after hjKey (by omega)]
have hqSuccPred : q - 1 + 1 = q := by omega
rw [hqSuccPred]
exact hlower
· rw [spliceKeys_get_after hjKey (Nat.le_of_lt hqAfter)]
exact hold.2
· intro child hchild
rcases mem_of_mem_spliceChildren hchild with hchildOld | rfl
· exact hchildrenBounded child hchildOld
· exact hnew.childBounded
have hdepth :
SameDepth
(node (ks.take j ++ ks.drop (j + 1))
(cs.take j ++ [newMerged] ++ cs.drop (j + 2))) := by
apply sameDepth_iff.mpr
constructor
· intro child hchild
rcases mem_of_mem_spliceChildren hchild with hchildOld | rfl
· exact sameDepth_children_sd hparent.sameDepth child hchildOld
· exact hnew.sameDepth
· intro child hchild other hother
have hchildHeight : heightOf child = heightOf left := by
rcases mem_of_mem_spliceChildren hchild with hchildOld | rfl
· exact hparent.siblings_height hchildOld hleftMem
· exact hnewHeightLeft
have hotherHeight : heightOf other = heightOf left := by
rcases mem_of_mem_spliceChildren hother with hotherOld | rfl
· exact hparent.siblings_height hotherOld hleftMem
· exact hnewHeightLeft
exact hchildHeight.trans hotherHeight.symm
have hnewMem :
newMerged ∈ cs.take j ++ [newMerged] ++ cs.drop (j + 2) := by
simp
have hparentHeight :
heightOf
(node (ks.take j ++ ks.drop (j + 1))
(cs.take j ++ [newMerged] ++ cs.drop (j + 2))) =
heightOf (node ks cs) := by
calc
heightOf
(node (ks.take j ++ ks.drop (j + 1))
(cs.take j ++ [newMerged] ++ cs.drop (j + 2))) =
1 + heightOf newMerged :=
heightOf_sameDepth_mem hdepth hnewMem
_ = 1 + heightOf left := by rw [hnewHeightLeft]
_ = heightOf (node ks cs) :=
(heightOf_sameDepth_mem hparent.sameDepth hleftMem).symm
have hkeys :
KeysSubset
(node (ks.take j ++ ks.drop (j + 1))
(cs.take j ++ [newMerged] ++ cs.drop (j + 2)))
(node ks cs) := by
intro k hk
simp only [keysOf, List.mem_append, List.mem_flatMap] at hk ⊢
rcases hk with hkey | ⟨child, hchild, hk⟩
· rcases hkey with hprefix | hsuffix
· exact Or.inl (List.mem_of_mem_take hprefix)
· exact Or.inl (List.mem_of_mem_drop hsuffix)
· rcases hchild with (hprefix | hnewChild) | hsuffix
· exact Or.inr
⟨child, List.mem_of_mem_take hprefix, hk⟩
· have hchildEq : child = newMerged := by simpa using hnewChild
subst child
have hkMerged := hsubset k hk
rw [mem_keysOf_mergeNodes] at hkMerged
rcases hkMerged with hkLeft | rfl | hkRight
· exact Or.inr ⟨left, hleftMem, hkLeft⟩
· exact Or.inl
(List.mem_iff_getElem?.mpr ⟨j, hsep⟩)
· exact Or.inr ⟨right, hrightMem, hkRight⟩
· exact Or.inr
⟨child, List.mem_of_mem_drop hsuffix, hk⟩
have hchildrenOcc :
∀ child ∈ cs.take j ++ [newMerged] ++ cs.drop (j + 2),
Occupancy t false child := by
intro child hchild
rcases mem_of_mem_spliceChildren hchild with hchildOld | rfl
· have hparentOcc := hparent.occupancy
unfold Occupancy at hparentOcc
exact hparentOcc.2.2.2 child hchildOld
· exact hnew.occupancy
cases b with
| false =>
have hreadyKeys : t ≤ ks.length := by
simpa [DeleteReady, numKeys] using hready
have hparentOcc := occupancy_false_dest hparent.occupancy
have hoccupancy :
Occupancy t false
(node (ks.take j ++ ks.drop (j + 1))
(cs.take j ++ [newMerged] ++ cs.drop (j + 2))) := by
apply occupancy_false_intro
· simp only [List.length_append, List.length_take, List.length_drop]
omega
· simp only [List.length_append, List.length_take, List.length_drop]
omega
· right
constructor
· simp only [List.length_append, List.length_take,
List.length_drop, List.length_cons, List.length_nil]
omega
· simp only [List.length_append, List.length_take,
List.length_drop, List.length_cons, List.length_nil]
rcases hparentOcc.2.2.1 with hempty | hinternal
· subst cs
simp at hright
· omega
· exact hchildrenOcc
exact
⟨⟨hsorted, hbounded, hoccupancy, hdepth⟩,
hparentHeight,
hkeys⟩
| true =>
have hparentOcc := hparent.occupancy
unfold Occupancy at hparentOcc
by_cases hsingle : ks.length = 1
· have hjZero : j = 0 := by omega
have hdropKeys : ks.drop 1 = [] := by
apply List.eq_nil_of_length_eq_zero
simp [hsingle]
have hdropChildren : cs.drop 2 = [] := by
apply List.eq_nil_of_length_eq_zero
simp [hcsLen, hsingle]
refine
⟨⟨hsorted, hbounded, hdepth, ?_⟩,
hparentHeight,
hkeys⟩
refine Or.inr ⟨newMerged, ?_, hnew.occupancy⟩
simp [hjZero, hdropKeys, hdropChildren]
· have hkeysAtLeastTwo : 2 ≤ ks.length := by omega
have hoccupancy :
Occupancy t true
(node (ks.take j ++ ks.drop (j + 1))
(cs.take j ++ [newMerged] ++ cs.drop (j + 2))) := by
unfold Occupancy
simp only [↓reduceIte]
have hnewKeysPos :
1 ≤ (ks.take j ++ ks.drop (j + 1)).length := by
simp only [List.length_append, List.length_take,
List.length_drop]
omega
have hnewKeysNotEmpty :
¬ ((ks.take j ++ ks.drop (j + 1)).length = 0 ∧
(cs.take j ++ [newMerged] ++ cs.drop (j + 2)).isEmpty) := by
omega
rw [if_neg hnewKeysNotEmpty]
refine ⟨hnewKeysPos, ?_, ?_, hchildrenOcc⟩
· simp only [List.length_append, List.length_take,
List.length_drop]
omega
· right
constructor
· simp only [List.length_append, List.length_take,
List.length_drop, List.length_cons, List.length_nil]
omega
· simp only [List.length_append, List.length_take,
List.length_drop, List.length_cons, List.length_nil]
rcases hparentOcc.2.2.1 with hempty | hinternal
· have : cs = [] := List.isEmpty_iff.mp hempty
subst cs
simp at hright
· omega
exact
⟨⟨hsorted, hbounded, hdepth, Or.inl hoccupancy⟩,
hparentHeight,
hkeys⟩
The positive-index merge-left branches use child index i and therefore
spell the separator index as i - 1. This is the exact output shape in
composedDelete.
theorem spliceMerged_left_packet
{t i sep : Nat} {b : Bool}
{ks : List Nat} {cs : List BTree}
{left right newMerged : BTree}
(hi : 0 < i)
(hparent : NodeWF t b (node ks cs))
(hready : DeleteReady t b (node ks cs))
(hsep : ks[i - 1]? = some sep)
(hleft : cs[i - 1]? = some left)
(hright : cs[i]? = some right)
(hnew : NodeWF t false newMerged)
(hheight :
heightOf newMerged = heightOf (mergeNodes left sep right))
(hsubset :
KeysSubset newMerged (mergeNodes left sep right)) :
let out :=
node (ks.take (i - 1) ++ ks.drop i)
(cs.take (i - 1) ++ [newMerged] ++ cs.drop (i + 1))
(if b then RootDeleteResult t out else NodeWF t false out) ∧
heightOf out = heightOf (node ks cs) ∧
KeysSubset out (node ks cs) := by
have hpacket :=
spliceMerged_packet hparent hready hsep hleft
(j := i - 1) (by simpa [show i - 1 + 1 = i by omega] using hright)
hnew hheight hsubset
simpa [show i - 1 + 1 = i by omega,
show i - 1 + 2 = i + 1 by omega] using hpacket
The no-left-sibling merge-right branch is the j = 0 specialization of the
atomic packet, in exactly the syntax returned by composedDelete.
theorem spliceMerged_zero_packet
{t sep : Nat} {b : Bool}
{ks : List Nat} {cs : List BTree}
{left right newMerged : BTree}
(hparent : NodeWF t b (node ks cs))
(hready : DeleteReady t b (node ks cs))
(hsep : ks[0]? = some sep)
(hleft : cs[0]? = some left)
(hright : cs[1]? = some right)
(hnew : NodeWF t false newMerged)
(hheight :
heightOf newMerged = heightOf (mergeNodes left sep right))
(hsubset :
KeysSubset newMerged (mergeNodes left sep right)) :
let out :=
node (ks.drop 1) ([newMerged] ++ cs.drop 2)
(if b then RootDeleteResult t out else NodeWF t false out) ∧
heightOf out = heightOf (node ks cs) ∧
KeysSubset out (node ks cs) := by
simpa using
(spliceMerged_packet hparent hready hsep hleft hright
hnew hheight hsubset)end BTreeend Chapter18end CLRSCLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.Occupancy
Non-root occupancy preservation for composed B-tree deletion
Raw composedDelete preserves non-root occupancy under the CLRS
descent-readiness guard. Raw root deletion has a deliberately different
contract: it may produce an empty root with one child, so root callers must
apply normalizeRoot rather than expect raw root occupancy.
namespace CLRS.Chapter18.BTree
Raw composed deletion preserves non-root occupancy when the node starts with
at least t keys. This is the occupancy projection of
composedDelete_nonRoot_preserves; the corresponding root operation is
composedDeleteRoot, which normalizes the permitted one-child transient.
lemma composedDelete_occupancy
(t x : Nat) (ht : 2 ≤ t) {tr : BTree}
(hinv : NodeWF t false tr) (hready : t ≤ numKeys tr) :
Occupancy t false (composedDelete t x tr) :=
(composedDelete_nonRoot_preserves t x ht hinv hready).2.1.occupancyend CLRS.Chapter18.BTreeCLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.Preservation
Bundled preservation for B-tree deletion
The raw node operation may leave a one-child empty root, so its root postcondition differs from the ordinary non-root invariant packet. This module proves both cases together and exposes root-normalized public results.
namespace CLRSnamespace Chapter18namespace BTree
The structural result expected from raw deletion at a node. Recursive calls
return an ordinary non-root packet; the top-level call permits the single
empty-root transient recorded by RootDeleteResult.
def RawDeleteResult (t : Nat) (isRoot : Bool) (tr : BTree) : Prop :=
if isRoot then RootDeleteResult t tr else NodeWF t false trAn ordinary invariant packet is always an admissible raw result.
theorem rawDeleteResult_of_nodeWF
{t : Nat} {isRoot : Bool} {tr : BTree}
(h : NodeWF t isRoot tr) :
RawDeleteResult t isRoot tr := by
cases isRoot with
| false =>
simpa [RawDeleteResult] using h
| true =>
simp only [RawDeleteResult, ↓reduceIte]
exact
⟨h.sorted, h.childBounded, h.sameDepth,
Or.inl h.occupancy⟩
The leaf branch preserves all structural facts. The readiness guard is used
only for a non-root leaf, where deleting one key must leave at least t - 1
keys.
theorem deleteLeaf_packet
{t x : Nat} {isRoot : Bool} {ks : List Nat}
(hinv : NodeWF t isRoot (node ks []))
(hready : DeleteReady t isRoot (node ks [])) :
let out := node (sortedRemove x ks) []
KeysSubset out (node ks []) ∧
RawDeleteResult t isRoot out ∧
heightOf out = heightOf (node ks []) := by
have hsorted : Sorted (node (sortedRemove x ks) []) := by
have hkeys := hinv.sorted
unfold Sorted at hkeys ⊢
exact
⟨sortedRemove_sorted x hkeys.1,
by simp⟩
have hbounded : ChildBounded (node (sortedRemove x ks) []) :=
childBounded_node_nil _
have hdepth : SameDepth (node (sortedRemove x ks) []) :=
SameDepth.leaf _
have hoccupancy :
Occupancy t isRoot (node (sortedRemove x ks) []) := by
have hold := hinv.occupancy
have hlengthLe := sortedRemove_length_le x ks
have hlengthGe := sortedRemove_length_ge x ks
cases isRoot with
| false =>
have hreadyKeys : t ≤ ks.length := by
simpa [DeleteReady, numKeys] using hready
unfold Occupancy at hold ⊢
simp only [Bool.false_eq_true, ↓reduceIte] at hold ⊢
refine ⟨by omega, by omega, by simp, by simp⟩
| true =>
unfold Occupancy at hold ⊢
simp only [↓reduceIte] at hold ⊢
refine ⟨?_, by omega, by simp, by simp⟩
by_cases hempty : sortedRemove x ks = []
· simp [hempty]
· have hzero : (sortedRemove x ks).length ≠ 0 := by
intro hlength
exact hempty (List.eq_nil_of_length_eq_zero hlength)
simp [hzero]
omega
have hout :
NodeWF t isRoot (node (sortedRemove x ks) []) :=
⟨hsorted, hbounded, hoccupancy, hdepth⟩
have hsubset :
KeysSubset (node (sortedRemove x ks) []) (node ks []) := by
intro k hk
simp only [keysOf, List.flatMap_nil, List.append_nil] at hk ⊢
exact mem_of_sortedRemove hk
exact
⟨hsubset, rawDeleteResult_of_nodeWF hout, by simp [heightOf]⟩end BTreeend Chapter18end CLRSCLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.Reassembly
Parent reassembly packets for B-tree deletion
This module packages the invariant bookkeeping needed after a recursive deletion result is put back into its parent.
namespace CLRSnamespace Chapter18namespace BTreenamespace ReassemblyInternalEvery key in a sufficiently short prefix of a pairwise ordered key list lies below the key at a later in-range index.
theorem pairwise_take_le_get
{ks : List Nat} (hp : List.Pairwise (· ≤ ·) ks)
{m j : Nat} (hj : j < ks.length) (hm : m ≤ j + 1) :
∀ k ∈ ks.take m, k ≤ ks[j] := by
intro k hk
rcases List.mem_iff_get.mp hk with ⟨q, hq⟩
have hqm : q.val < m :=
Nat.lt_of_lt_of_le q.isLt (List.length_take_le m ks)
have hqks : q.val < ks.length := by omega
have hkEq : k = ks.get ⟨q.val, hqks⟩ := by
calc
k = (ks.take m).get q := by rw [hq]
_ = ks.get ⟨q.val, hqks⟩ := by simp
rw [hkEq]
exact pairwise_get_mono hp (by omega) hqks hjEvery key in a suffix of a pairwise ordered key list lies above any earlier in-range key.
theorem pairwise_get_le_drop
{ks : List Nat} (hp : List.Pairwise (· ≤ ·) ks)
{j m : Nat} (hj : j < ks.length) (hjm : j ≤ m) :
∀ k ∈ ks.drop m, ks[j] ≤ k := by
intro k hk
rcases List.mem_iff_get.mp hk with ⟨q, hq⟩
have hidx : m + q.val < ks.length := by
have hq' : q.val < ks.length - m := by
simpa only [List.length_drop] using q.isLt
omega
have hkEq : k = ks.get ⟨m + q.val, hidx⟩ := by
calc
k = (ks.drop m).get q := by rw [hq]
_ = ks.get ⟨m + q.val, hidx⟩ := by simp
rw [hkEq]
exact pairwise_get_mono hp (by omega) hj hidxReplacing one child by an equally high well-formed child preserves the parent structure and height when the replacement's two parent-side key bounds are provided explicitly.
theorem replaceChild_nodeWF_height_of_bounds
{t i : Nat} {b : Bool} {ks : List Nat} {cs : List BTree}
{old new : BTree}
(hparent : NodeWF t b (node ks cs))
(hold : cs[i]? = some old)
(hnew : NodeWF t false new)
(hheight : heightOf new = heightOf old)
(hnewLower :
i = 0 ∨
(match ks[i - 1]? with
| some lower => ∀ k ∈ keysOf new, lower ≤ k
| none => True))
(hnewUpper :
match ks[i]? with
| some upper => ∀ k ∈ keysOf new, k ≤ upper
| none => True) :
NodeWF t b (node ks (cs.set i new)) ∧
heightOf (node ks (cs.set i new)) = heightOf (node ks cs) := by
obtain ⟨hi, _⟩ := List.getElem?_eq_some_iff.mp hold
have holdMem : old ∈ cs :=
List.mem_iff_getElem?.mpr ⟨i, hold⟩
have hnewMem : new ∈ cs.set i new :=
List.mem_set hi new
have hsorted : Sorted (node ks (cs.set i new)) := by
have hparentSorted := hparent.sorted
unfold Sorted at hparentSorted ⊢
refine ⟨hparentSorted.1, ?_⟩
intro child hchild
rcases List.mem_or_eq_of_mem_set hchild with hchildOld | rfl
· exact hparentSorted.2 child hchildOld
· exact hnew.sorted
have hbounded : ChildBounded (node ks (cs.set i new)) :=
childBounded_set hparent.childBounded hi hnew.childBounded
hnewLower hnewUpper
have hoccupancy : Occupancy t b (node ks (cs.set i new)) :=
occupancy_set hparent.occupancy hi hnew.occupancy
have hchildDepth :
∀ child ∈ cs.set i new, SameDepth child := by
intro child hchild
rcases List.mem_or_eq_of_mem_set hchild with hchildOld | rfl
· exact (sameDepth_iff.mp hparent.sameDepth).1 child hchildOld
· exact hnew.sameDepth
have hchildHeight :
∀ child ∈ cs.set i new, heightOf child = heightOf old := by
intro child hchild
rcases List.mem_or_eq_of_mem_set hchild with hchildOld | rfl
· exact hparent.siblings_height hchildOld holdMem
· exact hheight
have hdepth : SameDepth (node ks (cs.set i new)) := by
apply sameDepth_iff.mpr
refine ⟨hchildDepth, ?_⟩
intro left hleft right hright
exact (hchildHeight left hleft).trans
(hchildHeight right hright).symm
have hparentHeight :
heightOf (node ks (cs.set i new)) = heightOf (node ks cs) := by
calc
heightOf (node ks (cs.set i new)) =
1 + heightOf new :=
heightOf_sameDepth_mem hdepth hnewMem
_ = 1 + heightOf old := by rw [hheight]
_ = heightOf (node ks cs) :=
(heightOf_sameDepth_mem hparent.sameDepth holdMem).symm
exact
⟨⟨hsorted, hbounded, hoccupancy, hdepth⟩,
hparentHeight⟩end ReassemblyInternalReplacing one child by an equally high, well-formed key-subset preserves the complete parent invariant packet, the parent height, and the represented-key subset relation.
theorem replaceChild_packet
{t i : Nat} {b : Bool} {ks : List Nat} {cs : List BTree}
{old new : BTree}
(hparent : NodeWF t b (node ks cs))
(hold : cs[i]? = some old)
(hnew : NodeWF t false new)
(hheight : heightOf new = heightOf old)
(hsubset : KeysSubset new old) :
NodeWF t b (node ks (cs.set i new)) ∧
heightOf (node ks (cs.set i new)) = heightOf (node ks cs) ∧
KeysSubset (node ks (cs.set i new)) (node ks cs) := by
obtain ⟨hi, hget⟩ := List.getElem?_eq_some_iff.mp hold
have hget' : cs.get ⟨i, hi⟩ = old := by
rw [List.get_eq_getElem]
exact hget
have holdMem : old ∈ cs :=
List.mem_iff_getElem?.mpr ⟨i, hold⟩
have hparentBounded := hparent.childBounded
unfold ChildBounded at hparentBounded
obtain ⟨_, hbounds, _⟩ := hparentBounded
have hboundsOld := hbounds i hi
rw [hget'] at hboundsOld
have hnewLower :
i = 0 ∨
(match ks[i - 1]? with
| some lower => ∀ k ∈ keysOf new, lower ≤ k
| none => True) := by
rcases hboundsOld.1 with hiZero | hlower
· exact Or.inl hiZero
· right
cases hkey : ks[i - 1]? with
| none => trivial
| some lower =>
intro k hk
rw [hkey] at hlower
exact hlower k (hsubset k hk)
have hnewUpper :
match ks[i]? with
| some upper => ∀ k ∈ keysOf new, k ≤ upper
| none => True := by
cases hkey : ks[i]? with
| none => trivial
| some upper =>
intro k hk
rw [hkey] at hboundsOld
exact hboundsOld.2 k (hsubset k hk)
have hstruct :=
ReassemblyInternal.replaceChild_nodeWF_height_of_bounds
hparent hold hnew hheight hnewLower hnewUpper
have hkeys :
KeysSubset (node ks (cs.set i new)) (node ks cs) := by
intro k hk
simp only [keysOf, List.mem_append, List.mem_flatMap] at hk ⊢
rcases hk with hparentKey | ⟨child, hchild, hk⟩
· exact Or.inl hparentKey
· rcases List.mem_or_eq_of_mem_set hchild with hchildOld | rfl
· exact Or.inr ⟨child, hchildOld, hk⟩
· exact Or.inr ⟨old, holdMem, hsubset k hk⟩
exact
⟨hstruct.1,
hstruct.2,
hkeys⟩Replacing one separator preserves the structural invariant packet when the new separator lies above the entire key prefix and left child, and below the entire key suffix and right child. This theorem deliberately separates structural preservation from key provenance.
theorem replaceSeparator_nodeWF
{t i newSep : Nat} {b : Bool}
{ks : List Nat} {cs : List BTree}
(hparent : NodeWF t b (node ks cs))
(hi : i < ks.length)
(hleftKeys : ∀ k ∈ ks.take i, k ≤ newSep)
(hrightKeys : ∀ k ∈ ks.drop (i + 1), newSep ≤ k)
(hleftChild :
∀ child, cs[i]? = some child →
∀ k ∈ keysOf child, k ≤ newSep)
(hrightChild :
∀ child, cs[i + 1]? = some child →
∀ k ∈ keysOf child, newSep ≤ k) :
NodeWF t b (node (ks.set i newSep) cs) ∧
heightOf (node (ks.set i newSep) cs) =
heightOf (node ks cs) := by
have hsorted : Sorted (node (ks.set i newSep) cs) := by
have hparentSorted := hparent.sorted
unfold Sorted at hparentSorted ⊢
refine ⟨?_, hparentSorted.2⟩
rw [List.set_eq_take_cons_drop newSep hi]
apply List.pairwise_append.mpr
refine ⟨hparentSorted.1.take, ?_, ?_⟩
· exact List.pairwise_cons.mpr
⟨hrightKeys, hparentSorted.1.drop⟩
· intro left hleft right hright
rcases List.mem_cons.mp hright with rfl | hright
· exact hleftKeys left hleft
· exact (hleftKeys left hleft).trans
(hrightKeys right hright)
have hbounded : ChildBounded (node (ks.set i newSep) cs) := by
have hparentBounded := hparent.childBounded
unfold ChildBounded at hparentBounded ⊢
obtain ⟨hshape, hbounds, hchildren⟩ := hparentBounded
refine ⟨?_, ?_, hchildren⟩
· simpa using hshape
intro q hq
have hboundsOld := hbounds q hq
let child := cs.get ⟨q, hq⟩
show
(q = 0 ∨
(match (ks.set i newSep)[q - 1]? with
| some lower => ∀ k ∈ keysOf child, lower ≤ k
| none => True)) ∧
(match (ks.set i newSep)[q]? with
| some upper => ∀ k ∈ keysOf child, k ≤ upper
| none => True)
constructor
· by_cases hqZero : q = 0
· exact Or.inl hqZero
· right
by_cases hchanged : q - 1 = i
· have hqSucc : q = i + 1 := by omega
subst q
rw [hchanged, List.getElem?_set_eq_of_lt newSep hi]
exact hrightChild child
(List.getElem?_eq_getElem hq)
· rw [List.getElem?_set_ne (Ne.symm hchanged)]
rcases hboundsOld.1 with hqZero' | hlower
· exact absurd hqZero' hqZero
· exact hlower
· by_cases hchanged : q = i
· subst q
rw [List.getElem?_set_eq_of_lt newSep hi]
exact hleftChild child
(List.getElem?_eq_getElem hq)
· rw [List.getElem?_set_ne (Ne.symm hchanged)]
exact hboundsOld.2
have hoccupancy : Occupancy t b (node (ks.set i newSep) cs) := by
have hparentOccupancy := hparent.occupancy
unfold Occupancy at hparentOccupancy ⊢
simpa using hparentOccupancy
have hdepth : SameDepth (node (ks.set i newSep) cs) :=
sameDepth_keys_irrel hparent.sameDepth
exact
⟨⟨hsorted, hbounded, hoccupancy, hdepth⟩,
heightOf_keys_irrel _ _ _⟩Key provenance for separator replacement: if the new separator already occurred somewhere in the old parent tree, replacement cannot introduce a fresh represented key.
theorem replaceSeparator_keysSubset
{i newSep : Nat} {ks : List Nat} {cs : List BTree}
(hnewSep : newSep ∈ keysOf (node ks cs)) :
KeysSubset (node (ks.set i newSep) cs) (node ks cs) := by
have hnewSep' : newSep ∈ ks ∨ ∃ child ∈ cs, newSep ∈ keysOf child := by
simpa only [keysOf, List.mem_append, List.mem_flatMap] using hnewSep
intro k hk
simp only [keysOf, List.mem_append, List.mem_flatMap] at hk ⊢
rcases hk with hkey | hchild
· rcases List.mem_or_eq_of_mem_set hkey with hkeyOld | rfl
· exact Or.inl hkeyOld
· exact hnewSep'
· exact Or.inr hchildPredecessor/successor parent packets
private theorem replaceSeparatorChild_keysSubset
{separatorIndex childIndex newSep : Nat}
{ks : List Nat} {cs : List BTree} {old new : BTree}
(hold : cs[childIndex]? = some old)
(hnewSep : newSep ∈ keysOf (node ks cs))
(hsubset : KeysSubset new old) :
KeysSubset
(node (ks.set separatorIndex newSep) (cs.set childIndex new))
(node ks cs) := by
have holdMem : old ∈ cs :=
List.mem_iff_getElem?.mpr ⟨childIndex, hold⟩
have hnewSep' :
newSep ∈ ks ∨ ∃ child ∈ cs, newSep ∈ keysOf child := by
simpa only [keysOf, List.mem_append, List.mem_flatMap] using hnewSep
intro k hk
simp only [keysOf, List.mem_append, List.mem_flatMap] at hk ⊢
rcases hk with hkey | ⟨child, hchild, hk⟩
· rcases List.mem_or_eq_of_mem_set hkey with hkeyOld | rfl
· exact Or.inl hkeyOld
· exact hnewSep'
· rcases List.mem_or_eq_of_mem_set hchild with hchildOld | rfl
· exact Or.inr ⟨child, hchildOld, hk⟩
· exact Or.inr ⟨old, holdMem, hsubset k hk⟩
Case 1a parent reassembly. The predecessor from the original left child
replaces separator i, and an equally high recursive result replaces that
left child. The predecessor's provenance is established in the original
child, independently of whether recursive deletion retained it.
theorem replacePredecessor_packet
{t i sep : Nat} {b : Bool} {ks : List Nat} {cs : List BTree}
{left left' : BTree}
(ht : 2 ≤ t)
(hparent : NodeWF t b (node ks cs))
(hsep : ks[i]? = some sep)
(hleft : cs[i]? = some left)
(hleft' : NodeWF t false left')
(hheight : heightOf left' = heightOf left)
(hsubset : KeysSubset left' left) :
NodeWF t b
(node (ks.set i (maxKey left)) (cs.set i left')) ∧
heightOf (node (ks.set i (maxKey left)) (cs.set i left')) =
heightOf (node ks cs) ∧
KeysSubset
(node (ks.set i (maxKey left)) (cs.set i left'))
(node ks cs) := by
obtain ⟨hiKey, hsepGet⟩ := List.getElem?_eq_some_iff.mp hsep
obtain ⟨hiChild, hleftGetElem⟩ :=
List.getElem?_eq_some_iff.mp hleft
have hleftGet : cs.get ⟨i, hiChild⟩ = left := by
rw [List.get_eq_getElem]
exact hleftGetElem
have hleftMem : left ∈ cs :=
List.mem_iff_getElem?.mpr ⟨i, hleft⟩
have hleftWF : NodeWF t false left :=
hparent.child hleftMem
have hparentSorted := hparent.sorted
unfold Sorted at hparentSorted
have hleftPos : AllKeysPos left :=
hleftWF.nonRoot_allKeysPos ht
have hmaxMem : maxKey left ∈ keysOf left :=
maxKey_mem left hleftPos
have hmaxUpper : ∀ k ∈ keysOf left, k ≤ maxKey left :=
maxKey_ge left hleftWF.sorted hleftWF.childBounded hleftPos
have hparentBounded := hparent.childBounded
unfold ChildBounded at hparentBounded
obtain ⟨_, hbounds, _⟩ := hparentBounded
have hleftBounds := hbounds i hiChild
rw [hleftGet] at hleftBounds
have hmaxLeSep : maxKey left ≤ sep := by
have hupper := hleftBounds.2
rw [hsep] at hupper
exact hupper (maxKey left) hmaxMem
have hprefix : ∀ k ∈ ks.take i, k ≤ maxKey left := by
by_cases hiZero : i = 0
· subst i
simp
· have hiPos : 0 < i := Nat.pos_of_ne_zero hiZero
have hpredIndex : i - 1 < ks.length := by omega
have hpredLe : ks[i - 1] ≤ maxKey left := by
rcases hleftBounds.1 with hzero | hlower
· exact absurd hzero hiZero
· rw [List.getElem?_eq_getElem hpredIndex] at hlower
exact hlower (maxKey left) hmaxMem
intro k hk
exact
(ReassemblyInternal.pairwise_take_le_get
hparentSorted.1 hpredIndex
(by omega) k hk).trans hpredLe
have hsuffix :
∀ k ∈ ks.drop (i + 1), maxKey left ≤ k := by
intro k hk
have hsepLe : ks[i] ≤ k :=
ReassemblyInternal.pairwise_get_le_drop
hparentSorted.1 hiKey
(by omega) k hk
rw [hsepGet] at hsepLe
exact hmaxLeSep.trans hsepLe
have hleftChild :
∀ child, cs[i]? = some child →
∀ k ∈ keysOf child, k ≤ maxKey left := by
intro child hchild
have hchildEq : child = left :=
Option.some.inj (hchild.symm.trans hleft)
subst child
exact hmaxUpper
have hrightChild :
∀ child, cs[i + 1]? = some child →
∀ k ∈ keysOf child, maxKey left ≤ k := by
intro child hchild
obtain ⟨hci, hchildGetElem⟩ :=
List.getElem?_eq_some_iff.mp hchild
have hchildGet : cs.get ⟨i + 1, hci⟩ = child := by
rw [List.get_eq_getElem]
exact hchildGetElem
have hrightBounds := hbounds (i + 1) hci
rw [hchildGet] at hrightBounds
rcases hrightBounds.1 with hzero | hlower
· omega
· have hindex : i + 1 - 1 = i := by omega
rw [hindex, hsep] at hlower
intro k hk
exact hmaxLeSep.trans (hlower k hk)
have hseparator :=
replaceSeparator_nodeWF hparent hiKey hprefix hsuffix
hleftChild hrightChild
have hchild :=
replaceChild_packet hseparator.1 hleft hleft' hheight hsubset
have hmaxParent : maxKey left ∈ keysOf (node ks cs) := by
simp only [keysOf, List.mem_append, List.mem_flatMap]
exact Or.inr ⟨left, hleftMem, hmaxMem⟩
have hkeys :
KeysSubset
(node (ks.set i (maxKey left)) (cs.set i left'))
(node ks cs) :=
replaceSeparatorChild_keysSubset hleft hmaxParent hsubset
exact
⟨hchild.1,
hchild.2.1.trans hseparator.2,
hkeys⟩
Case 1b parent reassembly. The successor from the original right child
replaces separator i, and an equally high recursive result replaces child
i + 1. As in the predecessor packet, key provenance is tied to the
original child rather than to the recursive result.
theorem replaceSuccessor_packet
{t i sep : Nat} {b : Bool} {ks : List Nat} {cs : List BTree}
{right right' : BTree}
(ht : 2 ≤ t)
(hparent : NodeWF t b (node ks cs))
(hsep : ks[i]? = some sep)
(hright : cs[i + 1]? = some right)
(hright' : NodeWF t false right')
(hheight : heightOf right' = heightOf right)
(hsubset : KeysSubset right' right) :
NodeWF t b
(node (ks.set i (minKey right)) (cs.set (i + 1) right')) ∧
heightOf
(node (ks.set i (minKey right)) (cs.set (i + 1) right')) =
heightOf (node ks cs) ∧
KeysSubset
(node (ks.set i (minKey right)) (cs.set (i + 1) right'))
(node ks cs) := by
obtain ⟨hiKey, hsepGet⟩ := List.getElem?_eq_some_iff.mp hsep
obtain ⟨hiChild, hrightGetElem⟩ :=
List.getElem?_eq_some_iff.mp hright
have hrightGet : cs.get ⟨i + 1, hiChild⟩ = right := by
rw [List.get_eq_getElem]
exact hrightGetElem
have hrightMem : right ∈ cs :=
List.mem_iff_getElem?.mpr ⟨i + 1, hright⟩
have hrightWF : NodeWF t false right :=
hparent.child hrightMem
have hparentSorted := hparent.sorted
unfold Sorted at hparentSorted
have hrightPos : AllKeysPos right :=
hrightWF.nonRoot_allKeysPos ht
have hminMem : minKey right ∈ keysOf right :=
minKey_mem right hrightPos
have hminLower : ∀ k ∈ keysOf right, minKey right ≤ k :=
minKey_le right hrightWF.sorted hrightWF.childBounded hrightPos
have hparentBounded := hparent.childBounded
unfold ChildBounded at hparentBounded
obtain ⟨_, hbounds, _⟩ := hparentBounded
have hrightBounds := hbounds (i + 1) hiChild
rw [hrightGet] at hrightBounds
have hsepLeMin : sep ≤ minKey right := by
rcases hrightBounds.1 with hzero | hlower
· omega
· have hindex : i + 1 - 1 = i := by omega
rw [hindex, hsep] at hlower
exact hlower (minKey right) hminMem
have hprefix : ∀ k ∈ ks.take i, k ≤ minKey right := by
intro k hk
have hkSep : k ≤ ks[i] :=
ReassemblyInternal.pairwise_take_le_get
hparentSorted.1 hiKey
(by omega) k hk
rw [hsepGet] at hkSep
exact hkSep.trans hsepLeMin
have hsuffix :
∀ k ∈ ks.drop (i + 1), minKey right ≤ k := by
intro k hk
rcases List.mem_iff_get.mp hk with ⟨q, _⟩
have hnextIndex : i + 1 < ks.length := by
have hq' : q.val < ks.length - (i + 1) := by
simpa only [List.length_drop] using q.isLt
omega
have hupper := hrightBounds.2
rw [List.getElem?_eq_getElem hnextIndex] at hupper
have hminLeNext : minKey right ≤ ks[i + 1] :=
hupper (minKey right) hminMem
exact hminLeNext.trans
(ReassemblyInternal.pairwise_get_le_drop
hparentSorted.1 hnextIndex
(by omega) k hk)
have hleftChild :
∀ child, cs[i]? = some child →
∀ k ∈ keysOf child, k ≤ minKey right := by
intro child hchild
obtain ⟨hci, hchildGetElem⟩ :=
List.getElem?_eq_some_iff.mp hchild
have hchildGet : cs.get ⟨i, hci⟩ = child := by
rw [List.get_eq_getElem]
exact hchildGetElem
have hleftBounds := hbounds i hci
rw [hchildGet] at hleftBounds
have hupper := hleftBounds.2
rw [hsep] at hupper
intro k hk
exact (hupper k hk).trans hsepLeMin
have hrightChild :
∀ child, cs[i + 1]? = some child →
∀ k ∈ keysOf child, minKey right ≤ k := by
intro child hchild
have hchildEq : child = right :=
Option.some.inj (hchild.symm.trans hright)
subst child
exact hminLower
have hseparator :=
replaceSeparator_nodeWF hparent hiKey hprefix hsuffix
hleftChild hrightChild
have hchild :=
replaceChild_packet hseparator.1 hright hright' hheight hsubset
have hminParent : minKey right ∈ keysOf (node ks cs) := by
simp only [keysOf, List.mem_append, List.mem_flatMap]
exact Or.inr ⟨right, hrightMem, hminMem⟩
have hkeys :
KeysSubset
(node (ks.set i (minKey right)) (cs.set (i + 1) right'))
(node ks cs) :=
replaceSeparatorChild_keysSubset hright hminParent hsubset
exact
⟨hchild.1,
hchild.2.1.trans hseparator.2,
hkeys⟩end BTreeend Chapter18end CLRSCLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.Repair
Bundled local repair invariants for B-tree deletion
This module packages the component preservation lemmas for the three local
repairs used by composedDelete: merging two minimal siblings, borrowing
from a right sibling, and borrowing from a left sibling.
namespace CLRSnamespace Chapter18namespace BTree
Merging two minimal, equally deep siblings around their separator preserves
the complete non-root NodeWF packet and the height of the left sibling.
theorem mergeNodes_nodeWF {t : Nat} (ht : 2 ≤ t)
{left right : BTree} {sep : Nat}
(hleft : NodeWF t false left) (hright : NodeWF t false right)
(hleftKeys : numKeys left = t - 1)
(hrightKeys : numKeys right = t - 1)
(hheight : heightOf left = heightOf right)
(hleftLe : ∀ k ∈ keysOf left, k ≤ sep)
(hrightGe : ∀ k ∈ keysOf right, sep ≤ k) :
NodeWF t false (mergeNodes left sep right) ∧
heightOf (mergeNodes left sep right) = heightOf left := by
rcases left with ⟨lKeys, lCh⟩
rcases right with ⟨rKeys, rCh⟩
have hlk : lKeys.length = t - 1 := by
simpa [numKeys] using hleftKeys
have hrk : rKeys.length = t - 1 := by
simpa [numKeys] using hrightKeys
have hshape : (lCh = []) ↔ (rCh = []) :=
leaf_iff_of_height_eq hheight
refine ⟨?_, mergeNodes_height hleft.sameDepth hright.sameDepth hheight⟩
exact
⟨mergeNodes_sorted hleft.sorted hright.sorted hleftLe hrightGe,
mergeNodes_childBounded hleft.childBounded hright.childBounded
hshape hleftLe hrightGe,
mergeNodes_occupancy ht hlk hrk hleft.childBounded
hright.childBounded hleft.occupancy hright.occupancy,
mergeNodes_sameDepth hleft.sameDepth hright.sameDepth hheight⟩
Borrowing from the right sibling preserves the complete non-root
NodeWF packet for both result nodes and preserves each sibling's height.
theorem rotateRight_nodeWF {t : Nat} (ht : 2 ≤ t)
{left right : BTree} {sep : Nat}
(hleft : NodeWF t false left) (hright : NodeWF t false right)
(hleftKeys : numKeys left = t - 1)
(hrightKeys : t ≤ numKeys right)
(hheight : heightOf left = heightOf right)
(hleftLe : ∀ k ∈ keysOf left, k ≤ sep)
(hrightGe : ∀ k ∈ keysOf right, sep ≤ k) :
let repaired := rotateRight left sep right
NodeWF t false repaired.1 ∧ NodeWF t false repaired.2.2 ∧
heightOf repaired.1 = heightOf left ∧
heightOf repaired.2.2 = heightOf right := by
rcases left with ⟨lKeys, lCh⟩
rcases right with ⟨rKeys, rCh⟩
have hlk : lKeys.length = t - 1 := by
simpa [numKeys] using hleftKeys
have hrlen : t ≤ rKeys.length := by
simpa [numKeys] using hrightKeys
obtain ⟨rHead, rTail, rfl⟩ : ∃ rHead rTail, rKeys = rHead :: rTail := by
cases rKeys with
| nil =>
simp only [List.length_nil] at hrlen
omega
| cons rHead rTail =>
exact ⟨rHead, rTail, rfl⟩
have hshape : (lCh = []) ↔ (rCh = []) :=
leaf_iff_of_height_eq hheight
have hsep : sep ≤ rHead :=
hrightGe rHead (by simp [keysOf])
have hpreserves :=
rotateRight_preserves (sep := sep) ht hlk hrlen hleft.childBounded
hright.childBounded hleft.sameDepth hright.sameDepth
hleft.occupancy hright.occupancy hheight
have hsortedLeft :=
rotateRight_sorted_left hleft.sorted hright.sorted hleftLe hsep
have hboundedLeft :=
rotateRight_childBounded_left hleft.childBounded hright.childBounded
hshape hleftLe hrightGe
have hsortedRight :=
rotateRight_sorted_right hright.sorted
have hboundedRight :=
rotateRight_childBounded_right hright.childBounded
simp only [rotateRight_cons] at hpreserves ⊢
exact
⟨⟨hsortedLeft, hboundedLeft, hpreserves.1.1, hpreserves.1.2.1⟩,
⟨hsortedRight, hboundedRight, hpreserves.2.1, hpreserves.2.2.1⟩,
hpreserves.1.2.2,
hpreserves.2.2.2⟩
Borrowing from the left sibling preserves the complete non-root
NodeWF packet for both result nodes and preserves each sibling's height.
theorem rotateLeft_nodeWF {t : Nat} (ht : 2 ≤ t)
{left right : BTree} {sep : Nat}
(hleft : NodeWF t false left) (hright : NodeWF t false right)
(hleftKeys : t ≤ numKeys left)
(hrightKeys : numKeys right = t - 1)
(hheight : heightOf left = heightOf right)
(hleftLe : ∀ k ∈ keysOf left, k ≤ sep)
(hrightGe : ∀ k ∈ keysOf right, sep ≤ k) :
let repaired := rotateLeft left sep right
NodeWF t false repaired.1 ∧ NodeWF t false repaired.2.2 ∧
heightOf repaired.1 = heightOf left ∧
heightOf repaired.2.2 = heightOf right := by
rcases left with ⟨lKeys, lCh⟩
rcases right with ⟨rKeys, rCh⟩
have hllen : t ≤ lKeys.length := by
simpa [numKeys] using hleftKeys
have hrk : rKeys.length = t - 1 := by
simpa [numKeys] using hrightKeys
obtain ⟨lHead, lTail, rfl⟩ : ∃ lHead lTail, lKeys = lHead :: lTail := by
cases lKeys with
| nil =>
simp only [List.length_nil] at hllen
omega
| cons lHead lTail =>
exact ⟨lHead, lTail, rfl⟩
have hshape : (lCh = []) ↔ (rCh = []) :=
leaf_iff_of_height_eq hheight
have hpreservesLeft :=
rotateLeft_left ht hllen hleft.childBounded
hleft.occupancy hleft.sameDepth
have hpreservesRight :=
rotateLeft_right (sep := sep) ht hrk hright.childBounded hleft.sameDepth
hright.sameDepth hleft.occupancy hright.occupancy hheight
have hsortedLeft :=
rotateLeft_sorted_left hleft.sorted
have hboundedLeft :=
rotateLeft_childBounded_left hleft.childBounded
have hsortedRight :=
rotateLeft_sorted_right hleft.sorted hright.sorted hleftLe hrightGe
have hboundedRight :=
rotateLeft_childBounded_right hleft.childBounded hright.childBounded
hshape hleftLe hrightGe
simp only [rotateLeft_cons] at hpreservesLeft hpreservesRight ⊢
exact
⟨⟨hsortedLeft, hboundedLeft, hpreservesLeft.1, hpreservesLeft.2.1⟩,
⟨hsortedRight, hboundedRight, hpreservesRight.1, hpreservesRight.2.1⟩,
hpreservesLeft.2.2,
hpreservesRight.2.2⟩Readiness of repaired recursive targets
Merging a minimal left sibling with a separator produces a non-root target
with at least t keys, regardless of the right sibling's key count.
theorem mergeNodes_deleteReady {t : Nat} (ht : 2 ≤ t)
{left right : BTree} {sep : Nat}
(hleftKeys : numKeys left = t - 1) :
DeleteReady t false (mergeNodes left sep right) := by
rcases left with ⟨lKeys, lChildren⟩
rcases right with ⟨rKeys, rChildren⟩
simp only [DeleteReady, Bool.false_eq_true, false_or, numKeys,
mergeNodes_node, List.length_append, List.length_cons]
change lKeys.length = t - 1 at hleftKeys
omegaTwo adjacent non-ready siblings form a well-formed, ready recursive target when merged around their separator.
theorem mergeNodes_recursiveTarget {t : Nat} (ht : 2 ≤ t)
{left right : BTree} {sep : Nat}
(hleft : NodeWF t false left) (hright : NodeWF t false right)
(hleftNotReady : ¬ t ≤ numKeys left)
(hrightNotReady : ¬ t ≤ numKeys right)
(hheight : heightOf left = heightOf right)
(hleftLe : ∀ k ∈ keysOf left, k ≤ sep)
(hrightGe : ∀ k ∈ keysOf right, sep ≤ k) :
NodeWF t false (mergeNodes left sep right) ∧
DeleteReady t false (mergeNodes left sep right) ∧
heightOf (mergeNodes left sep right) = heightOf left := by
have hleftMin : numKeys left = t - 1 :=
numKeys_eq_t_sub_one_of_not_ready hleft.occupancy hleftNotReady
have hrightMin : numKeys right = t - 1 :=
numKeys_eq_t_sub_one_of_not_ready hright.occupancy hrightNotReady
have hmerged :=
mergeNodes_nodeWF ht hleft hright hleftMin hrightMin
hheight hleftLe hrightGe
exact
⟨hmerged.1, mergeNodes_deleteReady ht hleftMin, hmerged.2⟩
After borrowing from the right, the repaired left child has at least t
keys and is ready for recursive deletion.
theorem rotateRight_repaired_deleteReady {t : Nat} (ht : 2 ≤ t)
{left right : BTree} {sep : Nat}
(hleftKeys : numKeys left = t - 1)
(hrightKeys : t ≤ numKeys right) :
DeleteReady t false (rotateRight left sep right).1 := by
rcases left with ⟨lKeys, lChildren⟩
rcases right with ⟨rKeys, rChildren⟩
change lKeys.length = t - 1 at hleftKeys
change t ≤ rKeys.length at hrightKeys
obtain ⟨rHead, rTail, rfl⟩ : ∃ rHead rTail, rKeys = rHead :: rTail := by
cases rKeys with
| nil =>
simp only [List.length_nil] at hrightKeys
omega
| cons rHead rTail =>
exact ⟨rHead, rTail, rfl⟩
simp only [DeleteReady, Bool.false_eq_true, false_or, rotateRight_cons,
numKeys, List.length_append, List.length_cons, List.length_nil]
omega
After borrowing from the left, the repaired right child has at least t
keys and is ready for recursive deletion.
theorem rotateLeft_repaired_deleteReady {t : Nat} (ht : 2 ≤ t)
{left right : BTree} {sep : Nat}
(hleftKeys : t ≤ numKeys left)
(hrightKeys : numKeys right = t - 1) :
DeleteReady t false (rotateLeft left sep right).2.2 := by
rcases left with ⟨lKeys, lChildren⟩
rcases right with ⟨rKeys, rChildren⟩
change t ≤ lKeys.length at hleftKeys
change rKeys.length = t - 1 at hrightKeys
obtain ⟨lHead, lTail, rfl⟩ : ∃ lHead lTail, lKeys = lHead :: lTail := by
cases lKeys with
| nil =>
simp only [List.length_nil] at hleftKeys
omega
| cons lHead lTail =>
exact ⟨lHead, lTail, rfl⟩
simp only [DeleteReady, Bool.false_eq_true, false_or, rotateLeft_cons,
numKeys, List.length_cons]
omegaend BTreeend Chapter18end CLRSCLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.Rotation
B-tree deletion: rotations preserve Sorted and ChildBounded
This submodule collects the ordering and key-range preservation lemmas for the
two sibling rotations of CLRS B-TREE-DELETE case 3a: rotateRight
(the underflowing left child borrows the separator and the right sibling's
first child) and rotateLeft (the symmetric borrow from the left
sibling). For each rotation, both result nodes are shown to preserve the
Sorted invariant and the ChildBounded key-range invariant, given
the corresponding invariants on the two input siblings plus the
separator-ordering facts (hL_le, hR_ge) supplied by the parent's
ChildBounded invariant.
The hypothesis shape and proof technique mirror mergeNodes_sorted and
mergeNodes_childBounded: pairwise ordering of concatenated key lists,
and per-child bound transfer via getElem/getElem? index arithmetic over
the split and joined child lists.
namespace CLRSnamespace Chapter18namespace BTree
rotateRight: the new left node preserves Sorted
rotateRight new-left node is Sorted. The borrowed separator becomes
the new last key of the left child; hL_le (every key of the left sibling is
at most sep) is exactly what keeps the extended key list pairwise ordered.
The moved child rCh[0] inherits Sorted from the right sibling.
lemma rotateRight_sorted_left
{lKeys rTail : List Nat} {lCh rCh : List BTree} {sep rHead : Nat}
(hL_s : Sorted (node lKeys lCh)) (hR_s : Sorted (node (rHead :: rTail) rCh))
(hL_le : ∀ k ∈ keysOf (node lKeys lCh), k ≤ sep) (hsep : sep ≤ rHead) :
Sorted (node (lKeys ++ [sep]) (lCh ++ rCh.take 1)) := by
unfold Sorted at hL_s hR_s ⊢
obtain ⟨hL_pw, hL_ch⟩ := hL_s
obtain ⟨hR_pw, hR_ch⟩ := hR_s
refine ⟨?_, ?_⟩
· -- Pairwise (lKeys ++ [sep])
rw [List.pairwise_append]
refine ⟨hL_pw, by simp, ?_⟩
intro a ha b hb
simp only [List.mem_singleton] at hb
subst hb
exact hL_le a (by simp [keysOf, ha])
· -- children inherit Sorted from the two siblings
intro c hc
rw [List.mem_append] at hc
rcases hc with hc | hc
· exact hL_ch c hc
· exact hR_ch c (List.mem_of_mem_take hc)
rotateRight new-right node is Sorted. Dropping the first key and the
first child of the right sibling keeps both components of Sorted.
lemma rotateRight_sorted_right {rHead : Nat} {rTail : List Nat} {rCh : List BTree}
(hR_s : Sorted (node (rHead :: rTail) rCh)) :
Sorted (node rTail (rCh.drop 1)) := by
unfold Sorted at hR_s ⊢
obtain ⟨hR_pw, hR_ch⟩ := hR_s
exact ⟨(List.pairwise_cons.mp hR_pw).2,
fun c hc => hR_ch c ((List.drop_subset 1 rCh) hc)⟩
rotateRight: the new nodes preserve ChildBounded
rotateRight new-left node is ChildBounded. The appended child
rCh[0] sits between the new last key sep (lower bound, from hR_ge) and
no upper key; every other child keeps its original neighboring keys.
lemma rotateRight_childBounded_left
{lKeys rTail : List Nat} {lCh rCh : List BTree} {sep rHead : Nat}
(hL_cb : ChildBounded (node lKeys lCh))
(hR_cb : ChildBounded (node (rHead :: rTail) rCh))
(hshape : (lCh = []) ↔ (rCh = []))
(hL_le : ∀ k ∈ keysOf (node lKeys lCh), k ≤ sep)
(hR_ge : ∀ k ∈ keysOf (node (rHead :: rTail) rCh), sep ≤ k) :
ChildBounded (node (lKeys ++ [sep]) (lCh ++ rCh.take 1)) := by
unfold ChildBounded at hL_cb hR_cb ⊢
obtain ⟨hL_rel, hL_bounds, hL_sub⟩ := hL_cb
obtain ⟨hR_rel, hR_bounds, hR_sub⟩ := hR_cb
have hL_len : lCh = [] ∨ lCh.length = lKeys.length + 1 := by
rcases hL_rel with hLe | hLlen
· left; cases lCh with | nil => rfl | cons x xs => simp at hLe
· right; exact hLlen
have hR_len : rCh = [] ∨ rCh.length = (rHead :: rTail).length + 1 := by
rcases hR_rel with hRe | hRlen
· left; cases rCh with | nil => rfl | cons x xs => simp at hRe
· right; exact hRlen
refine ⟨?_, ?_, ?_⟩
· -- component 1: children count
rcases hL_len with hl | hLlen
· have hr : rCh = [] := hshape.mp hl
subst hl; subst hr; left; rfl
· rcases hR_len with hr | hRlen
· have hl0 : lCh = [] := hshape.mpr hr
rw [hl0] at hLlen; simp at hLlen
· right
simp only [List.length_append, List.length_take, List.length_cons,
List.length_nil, hLlen]
simp only [List.length_cons] at hRlen
omega
· -- component 2: per-child key bounds
intro i hi
by_cases hlCh : lCh = []
· have hrCh : rCh = [] := hshape.mp hlCh
subst hlCh; subst hrCh; simp at hi
· have hrCh : rCh ≠ [] := fun h => hlCh (hshape.mpr h)
have hLlen : lCh.length = lKeys.length + 1 := by
rcases hL_len with h | h
· exact absurd h hlCh
· exact h
have hRpos : 0 < rCh.length := by
rcases hR_len with h | h
· exact absurd h hrCh
· simp only [List.length_cons] at h; omega
have htake1 : (rCh.take 1).length = 1 := by
rw [List.length_take]; omega
refine ⟨?_, ?_⟩
· -- lower bound: (lKeys ++ [sep])[i-1]? bounds child i from below
rcases Nat.eq_zero_or_pos i with hi0 | hipos
· exact Or.inl hi0
· right
by_cases hiL : i < lCh.length
· -- child in the left segment: lower key is lKeys[i-1]
have hi1 : i - 1 < lKeys.length := by omega
have hchild : (lCh ++ rCh.take 1).get ⟨i, hi⟩ = lCh.get ⟨i, hiL⟩ :=
List.getElem_append_left hiL
have heq : (lKeys ++ [sep])[i-1]? = lKeys[i-1]? :=
List.getElem?_append_left (by omega)
rw [heq, List.getElem?_eq_getElem hi1]
have hb := (hL_bounds i hiL).1
rcases hb with h0 | hb
· omega
· simp only [List.getElem?_eq_getElem hi1] at hb
intro k hk
rw [hchild] at hk
exact hb k hk
· -- child is the moved rCh[0]: lower key is the separator
have hlo : (lKeys ++ [sep])[i-1]? = some sep := by
have e : i - 1 = lKeys.length := by
have hi' := hi
rw [List.length_append, htake1] at hi'
omega
rw [e, List.getElem?_append_right (Nat.le_refl _)]
simp
rw [hlo]
intro k hk
have hchild : (lCh ++ rCh.take 1).get ⟨i, hi⟩ = rCh.get ⟨0, hRpos⟩ := by
have hpi : i - lCh.length < (rCh.take 1).length := by
rw [htake1]
have hi' := hi
rw [List.length_append, htake1] at hi'
omega
have h1 : (lCh ++ rCh.take 1).get ⟨i, hi⟩ =
(rCh.take 1).get ⟨i - lCh.length, hpi⟩ :=
List.getElem_append_right (Nat.le_of_not_lt hiL)
rw [h1]
have hopt : (rCh.take 1)[i - lCh.length]? = rCh[0]? := by
have e : i - lCh.length = 0 := by
have hi' := hi
rw [List.length_append, htake1] at hi'
omega
rw [e, List.getElem?_take_of_lt Nat.zero_lt_one]
have ha := List.getElem?_eq_getElem hpi
have hb := List.getElem?_eq_getElem hRpos
rw [hopt] at ha
rw [ha] at hb
exact Option.some.inj hb
rw [hchild] at hk
have hmem : k ∈ keysOf (node (rHead :: rTail) rCh) := by
simp only [keysOf, List.mem_append, List.mem_flatMap]
exact Or.inr ⟨rCh.get ⟨0, hRpos⟩, List.getElem_mem _, hk⟩
exact hR_ge k hmem
· -- upper bound: (lKeys ++ [sep])[i]? bounds child i from above
by_cases hiL : i < lCh.length
· -- child in the left segment
have hchild : (lCh ++ rCh.take 1).get ⟨i, hi⟩ = lCh.get ⟨i, hiL⟩ :=
List.getElem_append_left hiL
by_cases hiK : i < lKeys.length
· -- upper key is lKeys[i]
have heq : (lKeys ++ [sep])[i]? = lKeys[i]? :=
List.getElem?_append_left hiK
rw [heq, List.getElem?_eq_getElem hiK]
have hub := (hL_bounds i hiL).2
simp only [List.getElem?_eq_getElem hiK] at hub
intro k hk
rw [hchild] at hk
exact hub k hk
· -- child is lCh[lKeys.length]: upper key is the separator
have hieq : i = lKeys.length := by omega
have heq : (lKeys ++ [sep])[i]? = some sep := by
rw [hieq, List.getElem?_append_right (Nat.le_refl _)]
simp
rw [heq]
intro k hk
rw [hchild] at hk
have hmem : k ∈ keysOf (node lKeys lCh) := by
simp only [keysOf, List.mem_append, List.mem_flatMap]
exact Or.inr ⟨lCh.get ⟨i, hiL⟩, List.getElem_mem _, hk⟩
exact hL_le k hmem
· -- child is the moved rCh[0]: no upper key
have hnone : (lKeys ++ [sep])[i]? = none := by
apply List.getElem?_eq_none
have hieq : i = lCh.length := by
have hi' := hi
rw [List.length_append, htake1] at hi'
omega
simp only [List.length_append, List.length_cons, List.length_nil]
omega
rw [hnone]
exact trivial
· -- component 3: recursive ChildBounded on children
intro c hc
rw [List.mem_append] at hc
rcases hc with hc | hc
· exact hL_sub c hc
· exact hR_sub c (List.mem_of_mem_take hc)
rotateRight new-right node is ChildBounded. Dropping the first key
and first child is the d = 1 case of childBounded_drop_of_full; the leaf
case keeps an empty child list.
lemma rotateRight_childBounded_right {rHead : Nat} {rTail : List Nat} {rCh : List BTree}
(hR_cb : ChildBounded (node (rHead :: rTail) rCh)) :
ChildBounded (node rTail (rCh.drop 1)) := by
by_cases hr : rCh = []
· subst hr
exact childBounded_node_nil rTail
· have hlen : rCh.length = (rHead :: rTail).length + 1 :=
(childBounded_children_rel hR_cb).resolve_left hr
have h1 : 1 < rCh.length := by
simp only [List.length_cons] at hlen; omega
exact childBounded_drop_of_full hR_cb (d := 1) (by omega) h1
rotateLeft: the new nodes preserve Sorted
rotateLeft new-left node is Sorted. The left sibling loses its last
key and last child; truncating preserves both components of Sorted.
lemma rotateLeft_sorted_left {lHead : Nat} {lTail : List Nat} {lCh : List BTree}
(hL_s : Sorted (node (lHead :: lTail) lCh)) :
Sorted (node (lHead :: lTail).dropLast (lCh.take (lCh.length - 1))) := by
unfold Sorted at hL_s ⊢
obtain ⟨hL_pw, hL_ch⟩ := hL_s
exact ⟨hL_pw.sublist (List.dropLast_sublist _),
fun c hc => hL_ch c (List.mem_of_mem_take hc)⟩
rotateLeft new-right node is Sorted. The separator becomes the new
first key of the right child; hR_ge (every key of the right sibling is at
least sep) keeps the extended key list pairwise ordered. The moved child
inherits Sorted from the left sibling.
lemma rotateLeft_sorted_right
{lHead : Nat} {lTail rKeys : List Nat} {lCh rCh : List BTree} {sep : Nat}
(hL_s : Sorted (node (lHead :: lTail) lCh)) (hR_s : Sorted (node rKeys rCh))
(_hL_le : ∀ k ∈ keysOf (node (lHead :: lTail) lCh), k ≤ sep)
(hR_ge : ∀ k ∈ keysOf (node rKeys rCh), sep ≤ k) :
Sorted (node (sep :: rKeys) (lCh.drop (lCh.length - 1) ++ rCh)) := by
unfold Sorted at hL_s hR_s ⊢
obtain ⟨hL_pw, hL_ch⟩ := hL_s
obtain ⟨hR_pw, hR_ch⟩ := hR_s
refine ⟨?_, ?_⟩
· -- Pairwise (sep :: rKeys)
apply List.Pairwise.cons
· intro k hk
exact hR_ge k (by simp [keysOf, hk])
· exact hR_pw
· -- children inherit Sorted from the two siblings
intro c hc
rw [List.mem_append] at hc
rcases hc with hc | hc
· exact hL_ch c ((List.drop_subset _ _) hc)
· exact hR_ch c hc
rotateLeft: the new nodes preserve ChildBounded
rotateLeft new-left node is ChildBounded. Dropping the last key and
last child is truncation to m = lTail.length, i.e. childBounded_take_of_full
with dropLast = take (length - 1); the leaf case keeps an empty child list.
lemma rotateLeft_childBounded_left {lHead : Nat} {lTail : List Nat} {lCh : List BTree}
(hL_cb : ChildBounded (node (lHead :: lTail) lCh)) :
ChildBounded (node (lHead :: lTail).dropLast (lCh.take (lCh.length - 1))) := by
by_cases hl : lCh = []
· subst hl
simp only [List.take_nil]
exact childBounded_node_nil _
· have hlen : lCh.length = (lHead :: lTail).length + 1 :=
(childBounded_children_rel hL_cb).resolve_left hl
rw [List.dropLast_eq_take]
simp only [List.length_cons] at hlen
have e1 : (lHead :: lTail).length - 1 = lTail.length := by simp
have e2 : lCh.length - 1 = lTail.length + 1 := by omega
rw [e1, e2]
exact childBounded_take_of_full hL_cb (by simp only [List.length_cons]; omega)
rotateLeft new-right node is ChildBounded. The prepended child (the
left sibling's last child) sits between no lower key and the new first key
sep (upper bound, from hL_le); every other child keeps its original
neighboring keys, shifted by one.
lemma rotateLeft_childBounded_right
{lHead : Nat} {lTail rKeys : List Nat} {lCh rCh : List BTree} {sep : Nat}
(hL_cb : ChildBounded (node (lHead :: lTail) lCh))
(hR_cb : ChildBounded (node rKeys rCh))
(hshape : (lCh = []) ↔ (rCh = []))
(hL_le : ∀ k ∈ keysOf (node (lHead :: lTail) lCh), k ≤ sep)
(hR_ge : ∀ k ∈ keysOf (node rKeys rCh), sep ≤ k) :
ChildBounded (node (sep :: rKeys) (lCh.drop (lCh.length - 1) ++ rCh)) := by
unfold ChildBounded at hL_cb hR_cb ⊢
obtain ⟨hL_rel, hL_bounds, hL_sub⟩ := hL_cb
obtain ⟨hR_rel, hR_bounds, hR_sub⟩ := hR_cb
have hL_len : lCh = [] ∨ lCh.length = (lHead :: lTail).length + 1 := by
rcases hL_rel with hLe | hLlen
· left; cases lCh with | nil => rfl | cons x xs => simp at hLe
· right; exact hLlen
have hR_len : rCh = [] ∨ rCh.length = rKeys.length + 1 := by
rcases hR_rel with hRe | hRlen
· left; cases rCh with | nil => rfl | cons x xs => simp at hRe
· right; exact hRlen
refine ⟨?_, ?_, ?_⟩
· -- component 1: children count
rcases hL_len with hl | hLlen
· have hr : rCh = [] := hshape.mp hl
subst hl; subst hr; left; rfl
· rcases hR_len with hr | hRlen
· have hl0 : lCh = [] := hshape.mpr hr
rw [hl0] at hLlen; simp at hLlen
· right
have hdroplen1 : (lCh.drop (lCh.length - 1)).length = 1 := by
rw [List.length_drop]
simp only [List.length_cons] at hLlen
omega
simp only [List.length_append, List.length_cons, hdroplen1]
omega
· -- component 2: per-child key bounds
intro i hi
by_cases hlCh : lCh = []
· have hrCh : rCh = [] := hshape.mp hlCh
subst hlCh; subst hrCh; simp at hi
· have hrCh : rCh ≠ [] := fun h => hlCh (hshape.mpr h)
have hLlen : lCh.length = lTail.length + 2 := by
rcases hL_len with h | h
· exact absurd h hlCh
· simp only [List.length_cons] at h; omega
have hRlen : rCh.length = rKeys.length + 1 := by
rcases hR_len with h | h
· exact absurd h hrCh
· exact h
have hdroplen : (lCh.drop (lCh.length - 1)).length = 1 := by
rw [List.length_drop]; omega
refine ⟨?_, ?_⟩
· -- lower bound: (sep :: rKeys)[i-1]? bounds child i from below
rcases Nat.eq_zero_or_pos i with hi0 | hipos
· exact Or.inl hi0
· right
have hj : i - 1 < rCh.length := by
have hi' := hi
rw [List.length_append, hdroplen] at hi'
omega
have hchild : (lCh.drop (lCh.length - 1) ++ rCh).get ⟨i, hi⟩ =
rCh.get ⟨i - 1, hj⟩ := by
have hopt : (lCh.drop (lCh.length - 1) ++ rCh)[i]? = rCh[i - 1]? := by
rw [List.getElem?_append_right (by rw [hdroplen]; omega), hdroplen]
have ha := List.getElem?_eq_getElem hi
have hb := List.getElem?_eq_getElem hj
rw [hopt] at ha
rw [ha] at hb
exact Option.some.inj hb
by_cases hj0 : i - 1 = 0
· -- child is rCh[0]: lower key is the separator
have h0 : (sep :: rKeys)[i-1]? = some sep := by simp [hj0]
rw [h0]
intro k hk
rw [hchild] at hk
have hmem : k ∈ keysOf (node rKeys rCh) := by
simp only [keysOf, List.mem_append, List.mem_flatMap]
exact Or.inr ⟨rCh.get ⟨i - 1, hj⟩, List.getElem_mem _, hk⟩
exact hR_ge k hmem
· -- lower key is rKeys[i-2]
have hj1 : i - 1 - 1 < rKeys.length := by omega
have hcons : (sep :: rKeys)[i-1]? = rKeys[i-1-1]? := by
conv_lhs => rw [show i - 1 = (i - 1 - 1) + 1 from by omega]
exact List.getElem?_cons_succ
rw [hcons, List.getElem?_eq_getElem hj1]
have hb := (hR_bounds (i - 1) hj).1
rcases hb with h0' | hb
· omega
· simp only [List.getElem?_eq_getElem hj1] at hb
intro k hk
rw [hchild] at hk
exact hb k hk
· -- upper bound: (sep :: rKeys)[i]? bounds child i from above
by_cases hi0 : i = 0
· -- child is the moved lCh-last child: upper key is the separator
subst hi0
have h0 : (sep :: rKeys)[0]? = some sep := by simp
rw [h0]
intro k hk
have hpos : lCh.length - 1 < lCh.length := by omega
have hchild : (lCh.drop (lCh.length - 1) ++ rCh).get ⟨0, hi⟩ =
lCh.get ⟨lCh.length - 1, hpos⟩ := by
have hopt : (lCh.drop (lCh.length - 1) ++ rCh)[0]? = lCh[lCh.length - 1]? := by
rw [List.getElem?_append_left (by rw [hdroplen]; omega),
List.getElem?_drop, Nat.add_zero]
have ha := List.getElem?_eq_getElem hi
have hb := List.getElem?_eq_getElem hpos
rw [hopt] at ha
rw [ha] at hb
exact Option.some.inj hb
rw [hchild] at hk
have hmem : k ∈ keysOf (node (lHead :: lTail) lCh) := by
simp only [keysOf, List.mem_append, List.mem_flatMap]
exact Or.inr ⟨lCh.get ⟨lCh.length - 1, hpos⟩, List.getElem_mem _, hk⟩
exact hL_le k hmem
· -- child is rCh[i-1]: upper key is rKeys[i-1]
have hj : i - 1 < rCh.length := by
have hi' := hi
rw [List.length_append, hdroplen] at hi'
omega
have hchild : (lCh.drop (lCh.length - 1) ++ rCh).get ⟨i, hi⟩ =
rCh.get ⟨i - 1, hj⟩ := by
have hopt : (lCh.drop (lCh.length - 1) ++ rCh)[i]? = rCh[i - 1]? := by
rw [List.getElem?_append_right (by rw [hdroplen]; omega), hdroplen]
have ha := List.getElem?_eq_getElem hi
have hb := List.getElem?_eq_getElem hj
rw [hopt] at ha
rw [ha] at hb
exact Option.some.inj hb
have heq : (sep :: rKeys)[i]? = rKeys[i-1]? := by
conv_lhs => rw [show i = (i - 1) + 1 from by omega]
exact List.getElem?_cons_succ
rw [heq]
by_cases hjK : i - 1 < rKeys.length
· rw [List.getElem?_eq_getElem hjK]
have hub := (hR_bounds (i - 1) hj).2
simp only [List.getElem?_eq_getElem hjK] at hub
intro k hk
rw [hchild] at hk
exact hub k hk
· -- child is rCh[rKeys.length]: no upper key
have hnone : rKeys[i-1]? = none := List.getElem?_eq_none (by omega)
rw [hnone]
exact trivial
· -- component 3: recursive ChildBounded on children
intro c hc
rw [List.mem_append] at hc
rcases hc with hc | hc
· exact hL_sub c ((List.drop_subset _ _) hc)
· exact hR_sub c hcend BTreeend Chapter18end CLRSCLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.RotationBounds
Separator bounds after B-tree deletion rotations
This module packages the two cross-node ordering facts needed when a repaired
sibling pair is reassembled into its parent. The proofs use the original
sibling's Sorted and ChildBounded invariants to account for the child
subtree that crosses the separator during a rotation.
namespace CLRSnamespace Chapter18namespace BTreeAfter borrowing from the right sibling, every key in the repaired left node is at most the new separator, and every key in the repaired right node is at least the new separator.
theorem rotateRight_separator_bounds {t : Nat}
{left right : BTree} {sep : Nat}
(hright : NodeWF t false right)
(hleftLe : ∀ k ∈ keysOf left, k ≤ sep)
(hrightGe : ∀ k ∈ keysOf right, sep ≤ k) :
let repaired := rotateRight left sep right
(∀ k ∈ keysOf repaired.1, k ≤ repaired.2.1) ∧
∀ k ∈ keysOf repaired.2.2, repaired.2.1 ≤ k := by
rcases left with ⟨lKeys, lCh⟩
rcases right with ⟨rKeys, rCh⟩
cases rKeys with
| nil =>
simp only [rotateRight_nil]
exact ⟨hleftLe, hrightGe⟩
| cons rHead rTail =>
have hsepHead : sep ≤ rHead :=
hrightGe rHead (by simp [keysOf])
have hhead : (rHead :: rTail)[0] = rHead := by
rfl
have hrightSorted := hright.sorted
unfold Sorted at hrightSorted
have hmovedUpper :
∀ k ∈ keysOf (node [] (rCh.take 1)), k ≤ rHead := by
simpa [hhead] using
(keysOf_take_le_pivot (m := 0) hrightSorted.1
hright.childBounded (by simp))
have hrightLower :
∀ k ∈ keysOf (node rTail (rCh.drop 1)), rHead ≤ k := by
simpa [hhead] using
(keysOf_drop_ge_pivot (m := 0) hrightSorted.1
hright.childBounded (by simp))
simp only [rotateRight_cons]
constructor
· intro k hk
simp only [keysOf, List.mem_append, List.mem_singleton,
List.flatMap_append] at hk
rcases hk with (hkey | rfl) | hchildren
· exact (hleftLe k (by
simp only [keysOf, List.mem_append]
exact Or.inl hkey)).trans hsepHead
· exact hsepHead
· rcases hchildren with hchild | hmoved
· exact (hleftLe k (by
simp only [keysOf, List.mem_append]
exact Or.inr hchild)).trans hsepHead
· exact hmovedUpper k (by
simpa only [keysOf, List.nil_append] using hmoved)
· exact hrightLowerAfter borrowing from the left sibling, every key in the repaired left node is at most the new separator, and every key in the repaired right node is at least the new separator.
theorem rotateLeft_separator_bounds {t : Nat}
{left right : BTree} {sep : Nat}
(hleft : NodeWF t false left)
(hleftLe : ∀ k ∈ keysOf left, k ≤ sep)
(hrightGe : ∀ k ∈ keysOf right, sep ≤ k) :
let repaired := rotateLeft left sep right
(∀ k ∈ keysOf repaired.1, k ≤ repaired.2.1) ∧
∀ k ∈ keysOf repaired.2.2, repaired.2.1 ≤ k := by
rcases left with ⟨lKeys, lCh⟩
rcases right with ⟨rKeys, rCh⟩
cases lKeys with
| nil =>
simp only [rotateLeft_nil]
exact ⟨hleftLe, hrightGe⟩
| cons lHead lTail =>
have hpivot :
(lHead :: lTail).getLast (List.cons_ne_nil lHead lTail) =
(lHead :: lTail)[lTail.length] := by
simpa using
(List.getLast_eq_getElem (List.cons_ne_nil lHead lTail))
have hchildrenCut :
lCh.take (lCh.length - 1) = lCh.take (lTail.length + 1) ∧
lCh.drop (lCh.length - 1) =
lCh.drop (lTail.length + 1) := by
rcases childBounded_children_rel hleft.childBounded with
hleaf | hinternal
· subst lCh
simp
· have hcut : lCh.length - 1 = lTail.length + 1 := by
simp only [List.length_cons] at hinternal
omega
rw [hcut]
exact ⟨rfl, rfl⟩
have hleftSorted := hleft.sorted
unfold Sorted at hleftSorted
have hleftUpper :
∀ k ∈
keysOf
(node (lHead :: lTail).dropLast
(lCh.take (lCh.length - 1))),
k ≤
(lHead :: lTail).getLast
(List.cons_ne_nil lHead lTail) := by
intro k hk
rw [List.dropLast_eq_take] at hk
simp only [List.length_cons, Nat.add_sub_cancel] at hk
rw [hchildrenCut.1] at hk
have hbound :=
keysOf_take_le_pivot (m := lTail.length) hleftSorted.1
hleft.childBounded (by simp) k hk
rwa [← hpivot] at hbound
have hmovedLower :
∀ k ∈ keysOf (node [] (lCh.drop (lCh.length - 1))),
(lHead :: lTail).getLast
(List.cons_ne_nil lHead lTail) ≤
k := by
intro k hk
rw [hchildrenCut.2] at hk
have hk' :
k ∈
keysOf
(node ((lHead :: lTail).drop (lTail.length + 1))
(lCh.drop (lTail.length + 1))) := by
simpa using hk
have hbound :=
keysOf_drop_ge_pivot (m := lTail.length) hleftSorted.1
hleft.childBounded (by simp) k hk'
rwa [← hpivot] at hbound
have hpivotLeSep :
(lHead :: lTail).getLast
(List.cons_ne_nil lHead lTail) ≤
sep :=
hleftLe _ (by
simp only [keysOf, List.mem_append]
exact
Or.inl
(List.getLast_mem
(List.cons_ne_nil lHead lTail)))
simp only [rotateLeft_cons]
constructor
· exact hleftUpper
· intro k hk
simp only [keysOf, List.mem_append, List.mem_cons,
List.flatMap_append] at hk
rcases hk with (rfl | hkey) | hchildren
· exact hpivotLeSep
· exact hpivotLeSep.trans
(hrightGe k (by
simp only [keysOf, List.mem_append]
exact Or.inl hkey))
· rcases hchildren with hmoved | hchild
· exact hmovedLower k (by
simpa only [keysOf, List.nil_append] using hmoved)
· exact hpivotLeSep.trans
(hrightGe k (by
simp only [keysOf, List.mem_append]
exact Or.inr hchild))end BTreeend Chapter18end CLRSCLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.RotationReassembly
Parent reassembly after B-tree deletion rotations
These packets cover the two case-3a descent branches. A sibling rotation changes a separator and both adjacent children atomically; after the recursive call returns, the repaired borrower is then replaced by its equal-height key-subset result.
namespace CLRSnamespace Chapter18namespace BTree
private theorem replaceAdjacent_keysSubset
{j sep newSep : Nat} {ks : List Nat} {cs : List BTree}
{left right newLeft newRight : BTree}
(hsep : ks[j]? = some sep)
(hleft : cs[j]? = some left)
(hright : cs[j + 1]? = some right)
(hrotation :
∀ k,
(k ∈ keysOf newLeft ∨ k = newSep ∨ k ∈ keysOf newRight) ↔
(k ∈ keysOf left ∨ k = sep ∨ k ∈ keysOf right)) :
KeysSubset
(node (ks.set j newSep)
((cs.set j newLeft).set (j + 1) newRight))
(node ks cs) := by
have hleftMem : left ∈ cs :=
List.mem_iff_getElem?.mpr ⟨j, hleft⟩
have hrightMem : right ∈ cs :=
List.mem_iff_getElem?.mpr ⟨j + 1, hright⟩
have hsepMem : sep ∈ ks :=
List.mem_iff_getElem?.mpr ⟨j, hsep⟩
have hsource :
∀ k, k ∈ keysOf left ∨ k = sep ∨ k ∈ keysOf right →
k ∈ keysOf (node ks cs) := by
intro k hk
simp only [keysOf, List.mem_append, List.mem_flatMap]
rcases hk with hkLeft | rfl | hkRight
· exact Or.inr ⟨left, hleftMem, hkLeft⟩
· exact Or.inl hsepMem
· exact Or.inr ⟨right, hrightMem, hkRight⟩
intro k hk
simp only [keysOf, List.mem_append, List.mem_flatMap] at hk
rcases hk with hkey | ⟨child, hchild, hkChild⟩
· rcases List.mem_or_eq_of_mem_set hkey with hkeyOld | rfl
· simp only [keysOf, List.mem_append]
exact Or.inl hkeyOld
· exact hsource k
((hrotation k).mp (Or.inr (Or.inl rfl)))
· rcases List.mem_or_eq_of_mem_set hchild with hchildFirst | rfl
· rcases List.mem_or_eq_of_mem_set hchildFirst with hchildOld | rfl
· simp only [keysOf, List.mem_append, List.mem_flatMap]
exact Or.inr ⟨child, hchildOld, hkChild⟩
· exact hsource k
((hrotation k).mp (Or.inl hkChild))
· exact hsource k
((hrotation k).mp (Or.inr (Or.inr hkChild)))private theorem rotateRight_right_keysSubset
(left : BTree) (sep : Nat) (right : BTree) :
KeysSubset (rotateRight left sep right).2.2 right := by
rcases left with ⟨lKeys, lChildren⟩
rcases right with ⟨rKeys, rChildren⟩
cases rKeys with
| nil =>
simp only [rotateRight_nil]
exact KeysSubset.refl _
| cons rHead rTail =>
intro k hk
simp only [rotateRight_cons, keysOf, List.mem_append,
List.mem_flatMap] at hk ⊢
rcases hk with hkKey | ⟨child, hchild, hkChild⟩
· exact Or.inl (List.mem_cons_of_mem rHead hkKey)
· exact Or.inr
⟨child, List.mem_of_mem_drop hchild, hkChild⟩private theorem rotateLeft_left_keysSubset
(left : BTree) (sep : Nat) (right : BTree) :
KeysSubset (rotateLeft left sep right).1 left := by
rcases left with ⟨lKeys, lChildren⟩
rcases right with ⟨rKeys, rChildren⟩
cases lKeys with
| nil =>
simp only [rotateLeft_nil]
exact KeysSubset.refl _
| cons lHead lTail =>
intro k hk
simp only [rotateLeft_cons, keysOf, List.mem_append,
List.mem_flatMap] at hk ⊢
rcases hk with hkKey | ⟨child, hchild, hkChild⟩
· exact Or.inl (List.mem_of_mem_dropLast hkKey)
· exact Or.inr
⟨child, List.mem_of_mem_take hchild, hkChild⟩private lemma rotateRight_newSeparator_mem_right
{t : Nat} (ht : 2 ≤ t)
(left : BTree) (sep : Nat) (right : BTree)
(hrightKeys : t ≤ numKeys right) :
(rotateRight left sep right).2.1 ∈ keysOf right := by
rcases left with ⟨lKeys, lChildren⟩
rcases right with ⟨rKeys, rChildren⟩
cases rKeys with
| nil =>
simp only [numKeys, List.length_nil] at hrightKeys
omega
| cons rHead rTail =>
simp [rotateRight_cons, keysOf]private lemma rotateLeft_newSeparator_mem_left
{t : Nat} (ht : 2 ≤ t)
(left : BTree) (sep : Nat) (right : BTree)
(hleftKeys : t ≤ numKeys left) :
(rotateLeft left sep right).2.1 ∈ keysOf left := by
rcases left with ⟨lKeys, lChildren⟩
rcases right with ⟨rKeys, rChildren⟩
cases lKeys with
| nil =>
simp only [numKeys, List.length_nil] at hleftKeys
omega
| cons lHead lTail =>
simp only [rotateLeft_cons, keysOf, List.mem_append]
exact Or.inl (List.getLast_mem (List.cons_ne_nil lHead lTail))The public packets follow. Each proof first installs the sibling that only loses material, changes the separator, installs the sibling that gains material with explicit outer bounds, and finally installs the recursive borrower result.
Reassemble a parent after borrowing from its right sibling and recursively deleting from the repaired left child.
theorem rotateRight_reassembly_packet
{t j sep : Nat} {b : Bool}
{ks : List Nat} {cs : List BTree}
{left right left' : BTree}
(ht : 2 ≤ t)
(hparent : NodeWF t b (node ks cs))
(hsep : ks[j]? = some sep)
(hleft : cs[j]? = some left)
(hright : cs[j + 1]? = some right)
(hleftKeys : numKeys left = t - 1)
(hrightKeys : t ≤ numKeys right)
(hleft' : NodeWF t false left')
(hheight :
heightOf left' = heightOf (rotateRight left sep right).1)
(hsubset :
KeysSubset left' (rotateRight left sep right).1) :
let repaired := rotateRight left sep right
NodeWF t b
(node (ks.set j repaired.2.1)
((cs.set j left').set (j + 1) repaired.2.2)) ∧
heightOf
(node (ks.set j repaired.2.1)
((cs.set j left').set (j + 1) repaired.2.2)) =
heightOf (node ks cs) ∧
KeysSubset
(node (ks.set j repaired.2.1)
((cs.set j left').set (j + 1) repaired.2.2))
(node ks cs) := by
dsimp only
obtain ⟨hjKey, hsepGetElem⟩ :=
List.getElem?_eq_some_iff.mp hsep
obtain ⟨hjLeft, hleftGetElem⟩ :=
List.getElem?_eq_some_iff.mp hleft
obtain ⟨hjRight, hrightGetElem⟩ :=
List.getElem?_eq_some_iff.mp hright
have hleftGet : cs.get ⟨j, hjLeft⟩ = left := by
rw [List.get_eq_getElem]
exact hleftGetElem
have hrightGet : cs.get ⟨j + 1, hjRight⟩ = right := by
rw [List.get_eq_getElem]
exact hrightGetElem
have hleftMem : left ∈ cs :=
List.mem_iff_getElem?.mpr ⟨j, hleft⟩
have hrightMem : right ∈ cs :=
List.mem_iff_getElem?.mpr ⟨j + 1, hright⟩
have hleftWF : NodeWF t false left :=
hparent.child hleftMem
have hrightWF : NodeWF t false right :=
hparent.child hrightMem
have hsiblings : heightOf left = heightOf right :=
hparent.siblings_height hleftMem hrightMem
have hparentSorted := hparent.sorted
unfold Sorted at hparentSorted
have hparentBounded := hparent.childBounded
unfold ChildBounded at hparentBounded
obtain ⟨_, hbounds, _⟩ := hparentBounded
have hleftBounds := hbounds j hjLeft
rw [hleftGet] at hleftBounds
have hrightBounds := hbounds (j + 1) hjRight
rw [hrightGet] at hrightBounds
have hleftLe : ∀ k ∈ keysOf left, k ≤ sep := by
have hupper := hleftBounds.2
rw [hsep] at hupper
exact hupper
have hrightGe : ∀ k ∈ keysOf right, sep ≤ k := by
rcases hrightBounds.1 with hzero | hlower
· omega
· rw [show j + 1 - 1 = j by omega, hsep] at hlower
exact hlower
have hrepair :=
rotateRight_nodeWF ht hleftWF hrightWF hleftKeys hrightKeys
hsiblings hleftLe hrightGe
dsimp only at hrepair
have hcross :=
rotateRight_separator_bounds hrightWF hleftLe hrightGe
dsimp only at hcross
have hnewSepMem :
(rotateRight left sep right).2.1 ∈ keysOf right :=
rotateRight_newSeparator_mem_right ht left sep right hrightKeys
have hsepLeNew : sep ≤ (rotateRight left sep right).2.1 :=
hrightGe _ hnewSepMem
have htrimRight :=
replaceChild_packet hparent hright hrepair.2.1 hrepair.2.2.2
(rotateRight_right_keysSubset left sep right)
have hprefix :
∀ k ∈ ks.take j, k ≤ (rotateRight left sep right).2.1 := by
intro k hk
have hkSep : k ≤ ks[j] :=
ReassemblyInternal.pairwise_take_le_get
hparentSorted.1 hjKey
(by omega) k hk
rw [hsepGetElem] at hkSep
exact hkSep.trans hsepLeNew
have hsuffix :
∀ k ∈ ks.drop (j + 1),
(rotateRight left sep right).2.1 ≤ k := by
intro k hk
rcases List.mem_iff_get.mp hk with ⟨q, _⟩
have hnextIndex : j + 1 < ks.length := by
have hq' : q.val < ks.length - (j + 1) := by
simpa only [List.length_drop] using q.isLt
omega
have hupper := hrightBounds.2
rw [List.getElem?_eq_getElem hnextIndex] at hupper
have hnewLeNext :
(rotateRight left sep right).2.1 ≤ ks[j + 1] :=
hupper _ hnewSepMem
exact hnewLeNext.trans
(ReassemblyInternal.pairwise_get_le_drop
hparentSorted.1 hnextIndex
(by omega) k hk)
have hleftAfterTrim :
(cs.set (j + 1) (rotateRight left sep right).2.2)[j]? =
some left := by
rw [List.getElem?_set_ne (by omega : j + 1 ≠ j)]
exact hleft
have hleftChild :
∀ child,
(cs.set (j + 1) (rotateRight left sep right).2.2)[j]? =
some child →
∀ k ∈ keysOf child,
k ≤ (rotateRight left sep right).2.1 := by
intro child hchild
have hchildEq : child = left :=
Option.some.inj (hchild.symm.trans hleftAfterTrim)
subst child
intro k hk
exact (hleftLe k hk).trans hsepLeNew
have hrightChild :
∀ child,
(cs.set (j + 1) (rotateRight left sep right).2.2)[j + 1]? =
some child →
∀ k ∈ keysOf child,
(rotateRight left sep right).2.1 ≤ k := by
intro child hchild
have hset :
(cs.set (j + 1) (rotateRight left sep right).2.2)[j + 1]? =
some (rotateRight left sep right).2.2 :=
List.getElem?_set_eq_of_lt _ hjRight
have hchildEq : child = (rotateRight left sep right).2.2 :=
Option.some.inj (hchild.symm.trans hset)
subst child
exact hcross.2
have hseparator :=
replaceSeparator_nodeWF htrimRight.1 hjKey hprefix hsuffix
hleftChild hrightChild
have hnewLeftLower :
j = 0 ∨
(match
(ks.set j (rotateRight left sep right).2.1)[j - 1]?
with
| some lower =>
∀ k ∈ keysOf (rotateRight left sep right).1, lower ≤ k
| none => True) := by
by_cases hjZero : j = 0
· exact Or.inl hjZero
· right
rw [List.getElem?_set_ne (by omega : j ≠ j - 1)]
cases hprev : ks[j - 1]? with
| none => trivial
| some lower =>
obtain ⟨hprevIndex, hprevGetElem⟩ :=
List.getElem?_eq_some_iff.mp hprev
have hprevLeSep : lower ≤ sep := by
have hp :=
pairwise_get_mono hparentSorted.1
(by omega) hprevIndex hjKey
simpa [hprevGetElem, hsepGetElem] using hp
intro k hk
have hsource :=
(mem_keysOf_rotateRight left sep right k).mp
(Or.inl hk)
rcases hsource with hkLeft | rfl | hkRight
· rcases hleftBounds.1 with hzero | hlower
· exact absurd hzero hjZero
· rw [hprev] at hlower
exact hlower k hkLeft
· exact hprevLeSep
· exact hprevLeSep.trans (hrightGe k hkRight)
have hnewLeftUpper :
match (ks.set j (rotateRight left sep right).2.1)[j]? with
| some upper =>
∀ k ∈ keysOf (rotateRight left sep right).1, k ≤ upper
| none => True := by
rw [List.getElem?_set_eq_of_lt _ hjKey]
exact hcross.1
have hrotatedReverse :=
ReassemblyInternal.replaceChild_nodeWF_height_of_bounds
hseparator.1 hleftAfterTrim hrepair.1 hrepair.2.2.1
hnewLeftLower hnewLeftUpper
have hcomm :
(cs.set (j + 1) (rotateRight left sep right).2.2).set j
(rotateRight left sep right).1 =
(cs.set j (rotateRight left sep right).1).set (j + 1)
(rotateRight left sep right).2.2 :=
List.set_comm _ _ (by omega)
rw [hcomm] at hrotatedReverse
have hrotatedHeight :
heightOf
(node (ks.set j (rotateRight left sep right).2.1)
((cs.set j (rotateRight left sep right).1).set (j + 1)
(rotateRight left sep right).2.2)) =
heightOf (node ks cs) :=
hrotatedReverse.2.trans
(hseparator.2.trans htrimRight.2.1)
have hrotatedSubset :
KeysSubset
(node (ks.set j (rotateRight left sep right).2.1)
((cs.set j (rotateRight left sep right).1).set (j + 1)
(rotateRight left sep right).2.2))
(node ks cs) :=
replaceAdjacent_keysSubset hsep hleft hright
(mem_keysOf_rotateRight left sep right)
have hleftAtRotated :
((cs.set j (rotateRight left sep right).1).set (j + 1)
(rotateRight left sep right).2.2)[j]? =
some (rotateRight left sep right).1 := by
rw [List.getElem?_set_ne (by omega : j + 1 ≠ j),
List.getElem?_set_eq_of_lt _ hjLeft]
have hfinal :=
replaceChild_packet hrotatedReverse.1 hleftAtRotated hleft'
hheight hsubset
have hfinalChildren :
(((cs.set j (rotateRight left sep right).1).set (j + 1)
(rotateRight left sep right).2.2).set j left') =
(cs.set j left').set (j + 1)
(rotateRight left sep right).2.2 := by
rw [List.set_comm _ _ (by omega : j + 1 ≠ j), List.set_set]
rw [hfinalChildren] at hfinal
exact
⟨hfinal.1,
hfinal.2.1.trans hrotatedHeight,
hfinal.2.2.trans hrotatedSubset⟩Reassemble a parent after borrowing from its left sibling and recursively deleting from the repaired right child.
theorem rotateLeft_reassembly_packet
{t j sep : Nat} {b : Bool}
{ks : List Nat} {cs : List BTree}
{left right right' : BTree}
(ht : 2 ≤ t)
(hparent : NodeWF t b (node ks cs))
(hsep : ks[j]? = some sep)
(hleft : cs[j]? = some left)
(hright : cs[j + 1]? = some right)
(hleftKeys : t ≤ numKeys left)
(hrightKeys : numKeys right = t - 1)
(hright' : NodeWF t false right')
(hheight :
heightOf right' = heightOf (rotateLeft left sep right).2.2)
(hsubset :
KeysSubset right' (rotateLeft left sep right).2.2) :
let repaired := rotateLeft left sep right
NodeWF t b
(node (ks.set j repaired.2.1)
((cs.set j repaired.1).set (j + 1) right')) ∧
heightOf
(node (ks.set j repaired.2.1)
((cs.set j repaired.1).set (j + 1) right')) =
heightOf (node ks cs) ∧
KeysSubset
(node (ks.set j repaired.2.1)
((cs.set j repaired.1).set (j + 1) right'))
(node ks cs) := by
dsimp only
obtain ⟨hjKey, hsepGetElem⟩ :=
List.getElem?_eq_some_iff.mp hsep
obtain ⟨hjLeft, hleftGetElem⟩ :=
List.getElem?_eq_some_iff.mp hleft
obtain ⟨hjRight, hrightGetElem⟩ :=
List.getElem?_eq_some_iff.mp hright
have hleftGet : cs.get ⟨j, hjLeft⟩ = left := by
rw [List.get_eq_getElem]
exact hleftGetElem
have hrightGet : cs.get ⟨j + 1, hjRight⟩ = right := by
rw [List.get_eq_getElem]
exact hrightGetElem
have hleftMem : left ∈ cs :=
List.mem_iff_getElem?.mpr ⟨j, hleft⟩
have hrightMem : right ∈ cs :=
List.mem_iff_getElem?.mpr ⟨j + 1, hright⟩
have hleftWF : NodeWF t false left :=
hparent.child hleftMem
have hrightWF : NodeWF t false right :=
hparent.child hrightMem
have hsiblings : heightOf left = heightOf right :=
hparent.siblings_height hleftMem hrightMem
have hparentSorted := hparent.sorted
unfold Sorted at hparentSorted
have hparentBounded := hparent.childBounded
unfold ChildBounded at hparentBounded
obtain ⟨_, hbounds, _⟩ := hparentBounded
have hleftBounds := hbounds j hjLeft
rw [hleftGet] at hleftBounds
have hrightBounds := hbounds (j + 1) hjRight
rw [hrightGet] at hrightBounds
have hleftLe : ∀ k ∈ keysOf left, k ≤ sep := by
have hupper := hleftBounds.2
rw [hsep] at hupper
exact hupper
have hrightGe : ∀ k ∈ keysOf right, sep ≤ k := by
rcases hrightBounds.1 with hzero | hlower
· omega
· rw [show j + 1 - 1 = j by omega, hsep] at hlower
exact hlower
have hrepair :=
rotateLeft_nodeWF ht hleftWF hrightWF hleftKeys hrightKeys
hsiblings hleftLe hrightGe
dsimp only at hrepair
have hcross :=
rotateLeft_separator_bounds hleftWF hleftLe hrightGe
dsimp only at hcross
have hnewSepMem :
(rotateLeft left sep right).2.1 ∈ keysOf left :=
rotateLeft_newSeparator_mem_left ht left sep right hleftKeys
have hnewLeSep : (rotateLeft left sep right).2.1 ≤ sep :=
hleftLe _ hnewSepMem
have htrimLeft :=
replaceChild_packet hparent hleft hrepair.1 hrepair.2.2.1
(rotateLeft_left_keysSubset left sep right)
have hprefix :
∀ k ∈ ks.take j, k ≤ (rotateLeft left sep right).2.1 := by
by_cases hjZero : j = 0
· subst j
simp
· have hprevIndex : j - 1 < ks.length := by omega
have hleftLower := hleftBounds.1
rcases hleftLower with hzero | hleftLower
· exact absurd hzero hjZero
· rw [List.getElem?_eq_getElem hprevIndex] at hleftLower
have hprevLeNew :
ks[j - 1] ≤ (rotateLeft left sep right).2.1 :=
hleftLower _ hnewSepMem
intro k hk
exact
(ReassemblyInternal.pairwise_take_le_get
hparentSorted.1 hprevIndex
(by omega) k hk).trans hprevLeNew
have hsuffix :
∀ k ∈ ks.drop (j + 1),
(rotateLeft left sep right).2.1 ≤ k := by
intro k hk
have hsepLe : ks[j] ≤ k :=
ReassemblyInternal.pairwise_get_le_drop
hparentSorted.1 hjKey
(by omega) k hk
rw [hsepGetElem] at hsepLe
exact hnewLeSep.trans hsepLe
have hleftChild :
∀ child,
(cs.set j (rotateLeft left sep right).1)[j]? =
some child →
∀ k ∈ keysOf child,
k ≤ (rotateLeft left sep right).2.1 := by
intro child hchild
have hset :
(cs.set j (rotateLeft left sep right).1)[j]? =
some (rotateLeft left sep right).1 :=
List.getElem?_set_eq_of_lt _ hjLeft
have hchildEq : child = (rotateLeft left sep right).1 :=
Option.some.inj (hchild.symm.trans hset)
subst child
exact hcross.1
have hrightAfterTrim :
(cs.set j (rotateLeft left sep right).1)[j + 1]? =
some right := by
rw [List.getElem?_set_ne (by omega : j ≠ j + 1)]
exact hright
have hrightChild :
∀ child,
(cs.set j (rotateLeft left sep right).1)[j + 1]? =
some child →
∀ k ∈ keysOf child,
(rotateLeft left sep right).2.1 ≤ k := by
intro child hchild
have hchildEq : child = right :=
Option.some.inj (hchild.symm.trans hrightAfterTrim)
subst child
intro k hk
exact hnewLeSep.trans (hrightGe k hk)
have hseparator :=
replaceSeparator_nodeWF htrimLeft.1 hjKey hprefix hsuffix
hleftChild hrightChild
have hnewRightLower :
j + 1 = 0 ∨
(match
(ks.set j (rotateLeft left sep right).2.1)[j + 1 - 1]?
with
| some lower =>
∀ k ∈ keysOf (rotateLeft left sep right).2.2, lower ≤ k
| none => True) := by
right
rw [show j + 1 - 1 = j by omega,
List.getElem?_set_eq_of_lt _ hjKey]
exact hcross.2
have hnewRightUpper :
match (ks.set j (rotateLeft left sep right).2.1)[j + 1]? with
| some upper =>
∀ k ∈ keysOf (rotateLeft left sep right).2.2, k ≤ upper
| none => True := by
rw [List.getElem?_set_ne (by omega : j ≠ j + 1)]
cases hnext : ks[j + 1]? with
| none => trivial
| some upper =>
obtain ⟨hnextIndex, hnextGetElem⟩ :=
List.getElem?_eq_some_iff.mp hnext
have hsepUpper : sep ≤ upper := by
have hp :=
pairwise_get_mono hparentSorted.1
(by omega) hjKey hnextIndex
simpa [hsepGetElem, hnextGetElem] using hp
have hrightUpper := hrightBounds.2
rw [hnext] at hrightUpper
intro k hk
have hsource :=
(mem_keysOf_rotateLeft left sep right k).mp
(Or.inr (Or.inr hk))
rcases hsource with hkLeft | rfl | hkRight
· exact (hleftLe k hkLeft).trans hsepUpper
· exact hsepUpper
· exact hrightUpper k hkRight
have hrotated :=
ReassemblyInternal.replaceChild_nodeWF_height_of_bounds
hseparator.1 hrightAfterTrim hrepair.2.1 hrepair.2.2.2
hnewRightLower hnewRightUpper
have hrotatedHeight :
heightOf
(node (ks.set j (rotateLeft left sep right).2.1)
((cs.set j (rotateLeft left sep right).1).set (j + 1)
(rotateLeft left sep right).2.2)) =
heightOf (node ks cs) :=
hrotated.2.trans
(hseparator.2.trans htrimLeft.2.1)
have hrotatedSubset :
KeysSubset
(node (ks.set j (rotateLeft left sep right).2.1)
((cs.set j (rotateLeft left sep right).1).set (j + 1)
(rotateLeft left sep right).2.2))
(node ks cs) :=
replaceAdjacent_keysSubset hsep hleft hright
(mem_keysOf_rotateLeft left sep right)
have hrightAtRotated :
((cs.set j (rotateLeft left sep right).1).set (j + 1)
(rotateLeft left sep right).2.2)[j + 1]? =
some (rotateLeft left sep right).2.2 :=
List.getElem?_set_eq_of_lt _ (by
simpa using hjRight)
have hfinal :=
replaceChild_packet hrotated.1 hrightAtRotated hright'
hheight hsubset
simpa only [List.set_set] using
And.intro hfinal.1
(And.intro
(hfinal.2.1.trans hrotatedHeight)
(hfinal.2.2.trans hrotatedSubset))end BTreeend Chapter18end CLRSCLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.SameDepthHeight
Same-depth and raw-height preservation for composed B-tree deletion
This module proves the equal-leaf-depth and raw-height conclusions for
composedDelete by an independent induction over the deletion program.
Only recursive child-count shape and equal child heights are used: key order,
occupancy, minimum-degree side conditions, and root status are irrelevant.
namespace CLRS.Chapter18.BTree
The recursive shape fragment of ChildBounded: every node is either a leaf or
has one more child than key, and the same property holds recursively.
private inductive DeletionShape : BTree → Prop
| mk (ks : List Nat) (cs : List BTree)
(childrenRel : cs = [] ∨ cs.length = ks.length + 1)
(childrenShape : ∀ child ∈ cs, DeletionShape child) :
DeletionShape (node ks cs)
The root child-count relation carried by DeletionShape.
private lemma DeletionShape.childrenRel
{ks : List Nat} {cs : List BTree}
(h : DeletionShape (node ks cs)) :
cs = [] ∨ cs.length = ks.length + 1 := by
cases h with
| mk _ _ hrel _ => exact hrel
Every child of a DeletionShape node recursively has DeletionShape.
private lemma DeletionShape.child
{ks : List Nat} {cs : List BTree}
(h : DeletionShape (node ks cs)) :
∀ child ∈ cs, DeletionShape child := by
cases h with
| mk _ _ _ hchildren => exact hchildren
ChildBounded contains DeletionShape; separator bounds are deliberately
discarded because same-depth and height preservation depend only on shape.
private theorem deletionShape_of_childBounded
(tr : BTree) (hbounded : ChildBounded tr) :
DeletionShape tr := by
let motiveTree :=
fun tree : BTree => ChildBounded tree → DeletionShape tree
let motiveChildren :=
fun children : List BTree =>
(∀ child ∈ children, ChildBounded child) →
∀ child ∈ children, DeletionShape child
exact
(@BTree.rec motiveTree motiveChildren
(fun ks cs childrenIH hnode => by
unfold ChildBounded at hnode
refine DeletionShape.mk ks cs ?_ (childrenIH hnode.2.2)
rcases hnode.1 with hempty | hlength
· exact Or.inl (List.isEmpty_iff.mp hempty)
· exact Or.inr hlength)
(by
intro _ child hchild
simp at hchild)
(fun head tail headIH tailIH hchildren child hchild => by
rcases List.mem_cons.mp hchild with rfl | htail
· exact headIH (hchildren child (by simp))
· exact tailIH
(fun c hc => hchildren c (by simp [hc]))
child htail)
tr) hboundedReplacing one child by a same-depth, equal-height shape preserves the parent's recursive shape, same-depth invariant, and raw height.
private theorem replaceChild_shape_depth_height
{i : Nat} {ks : List Nat} {cs : List BTree} {old new : BTree}
(hshape : DeletionShape (node ks cs))
(hdepth : SameDepth (node ks cs))
(hold : cs[i]? = some old)
(hnewShape : DeletionShape new)
(hnewDepth : SameDepth new)
(hheight : heightOf new = heightOf old) :
DeletionShape (node ks (cs.set i new)) ∧
SameDepth (node ks (cs.set i new)) ∧
heightOf (node ks (cs.set i new)) = heightOf (node ks cs) := by
obtain ⟨hi, _⟩ := List.getElem?_eq_some_iff.mp hold
have holdMem : old ∈ cs :=
List.mem_iff_getElem?.mpr ⟨i, hold⟩
have hnewMem : new ∈ cs.set i new :=
List.mem_set hi new
have hcsne : cs ≠ [] := by
intro hnil
subst cs
simp at hold
have hlength : cs.length = ks.length + 1 :=
hshape.childrenRel.resolve_left hcsne
have houtShape : DeletionShape (node ks (cs.set i new)) := by
apply DeletionShape.mk
· right
simpa using hlength
· intro child hchild
rcases List.mem_or_eq_of_mem_set hchild with hchildOld | rfl
· exact hshape.child child hchildOld
· exact hnewShape
have houtChildrenDepth :
∀ child ∈ cs.set i new, SameDepth child := by
intro child hchild
rcases List.mem_or_eq_of_mem_set hchild with hchildOld | rfl
· exact (sameDepth_iff.mp hdepth).1 child hchildOld
· exact hnewDepth
have houtChildrenHeight :
∀ child ∈ cs.set i new, heightOf child = heightOf old := by
intro child hchild
rcases List.mem_or_eq_of_mem_set hchild with hchildOld | rfl
· exact (sameDepth_iff.mp hdepth).2 child hchildOld old holdMem
· exact hheight
have houtDepth : SameDepth (node ks (cs.set i new)) :=
sameDepth_iff.mpr
⟨houtChildrenDepth, fun left hleft right hright =>
(houtChildrenHeight left hleft).trans
(houtChildrenHeight right hright).symm⟩
have houtHeight :
heightOf (node ks (cs.set i new)) = heightOf (node ks cs) := by
calc
heightOf (node ks (cs.set i new)) = 1 + heightOf new :=
heightOf_sameDepth_mem houtDepth hnewMem
_ = 1 + heightOf old := by rw [hheight]
_ = heightOf (node ks cs) :=
(heightOf_sameDepth_mem hdepth holdMem).symm
exact ⟨houtShape, houtDepth, houtHeight⟩Changing only a node's key list preserves recursive shape when its length is unchanged; same-depth and raw height never depend on those keys.
private theorem replaceKeys_shape_depth_height
{oldKeys newKeys : List Nat} {cs : List BTree}
(hshape : DeletionShape (node oldKeys cs))
(hdepth : SameDepth (node oldKeys cs))
(hlength : newKeys.length = oldKeys.length) :
DeletionShape (node newKeys cs) ∧
SameDepth (node newKeys cs) ∧
heightOf (node newKeys cs) = heightOf (node oldKeys cs) := by
have houtShape : DeletionShape (node newKeys cs) := by
apply DeletionShape.mk
· rcases hshape.childrenRel with hleaf | hinternal
· exact Or.inl hleaf
· right
omega
· exact hshape.child
exact
⟨houtShape, sameDepth_keys_irrel hdepth,
heightOf_keys_irrel newKeys oldKeys cs⟩Merging equal-height sibling shapes preserves recursive shape, same depth, and the common sibling height; no separator-order or occupancy facts are needed.
private theorem mergeNodes_shape_depth_height
{left right : BTree} {sep : Nat}
(hleftShape : DeletionShape left)
(hrightShape : DeletionShape right)
(hleftDepth : SameDepth left)
(hrightDepth : SameDepth right)
(hheight : heightOf left = heightOf right) :
DeletionShape (mergeNodes left sep right) ∧
SameDepth (mergeNodes left sep right) ∧
heightOf (mergeNodes left sep right) = heightOf left := by
rcases left with ⟨lKeys, lChildren⟩
rcases right with ⟨rKeys, rChildren⟩
have hshapeMatch : lChildren = [] ↔ rChildren = [] :=
leaf_iff_of_height_eq hheight
have hmergedShape :
DeletionShape
(mergeNodes (node lKeys lChildren) sep
(node rKeys rChildren)) := by
rw [mergeNodes_node]
apply DeletionShape.mk
· by_cases hleftLeaf : lChildren = []
· left
rw [hleftLeaf, hshapeMatch.mp hleftLeaf]
rfl
· right
have hrightInternal : rChildren ≠ [] :=
fun hrightLeaf => hleftLeaf (hshapeMatch.mpr hrightLeaf)
have hleftLength :
lChildren.length = lKeys.length + 1 :=
hleftShape.childrenRel.resolve_left hleftLeaf
have hrightLength :
rChildren.length = rKeys.length + 1 :=
hrightShape.childrenRel.resolve_left hrightInternal
simp only [List.length_append, List.length_cons]
omega
· intro child hchild
rw [List.mem_append] at hchild
rcases hchild with hleftMem | hrightMem
· exact hleftShape.child child hleftMem
· exact hrightShape.child child hrightMem
exact
⟨hmergedShape,
mergeNodes_sameDepth hleftDepth hrightDepth hheight,
mergeNodes_height hleftDepth hrightDepth hheight⟩Reassembling an internal node from recursively shaped, same-depth children of one common height preserves the height of an old same-depth parent.
private theorem reassembleInternal_shape_depth_height
{oldKeys newKeys : List Nat} {oldChildren newChildren : List BTree}
{oldWitness : BTree}
(holdDepth : SameDepth (node oldKeys oldChildren))
(holdWitness : oldWitness ∈ oldChildren)
(hchildrenLength : newChildren.length = newKeys.length + 1)
(hchildrenShape : ∀ child ∈ newChildren, DeletionShape child)
(hchildrenDepth : ∀ child ∈ newChildren, SameDepth child)
(hchildrenHeight :
∀ child ∈ newChildren, heightOf child = heightOf oldWitness) :
DeletionShape (node newKeys newChildren) ∧
SameDepth (node newKeys newChildren) ∧
heightOf (node newKeys newChildren) =
heightOf (node oldKeys oldChildren) := by
have hnewLengthPos : 0 < newChildren.length := by
omega
let newWitness :=
newChildren.get ⟨0, hnewLengthPos⟩
have hnewWitness : newWitness ∈ newChildren :=
List.get_mem newChildren ⟨0, hnewLengthPos⟩
have hnewShape : DeletionShape (node newKeys newChildren) :=
DeletionShape.mk newKeys newChildren (Or.inr hchildrenLength)
hchildrenShape
have hnewDepth : SameDepth (node newKeys newChildren) :=
sameDepth_iff.mpr
⟨hchildrenDepth, fun left hleft right hright =>
(hchildrenHeight left hleft).trans
(hchildrenHeight right hright).symm⟩
have hnewHeight :
heightOf (node newKeys newChildren) =
heightOf (node oldKeys oldChildren) := by
calc
heightOf (node newKeys newChildren) =
1 + heightOf newWitness :=
heightOf_sameDepth_mem hnewDepth hnewWitness
_ = 1 + heightOf oldWitness := by
rw [hchildrenHeight newWitness hnewWitness]
_ = heightOf (node oldKeys oldChildren) :=
(heightOf_sameDepth_mem holdDepth holdWitness).symm
exact ⟨hnewShape, hnewDepth, hnewHeight⟩Borrowing from the right sibling preserves the recursive shape, same depth, and height of both siblings. The empty-lender branch is the defining identity case; the nonempty branch uses only the siblings' common height and shape.
private theorem rotateRight_shape_depth_height
(left : BTree) (sep : Nat) (right : BTree)
(hleftShape : DeletionShape left)
(hrightShape : DeletionShape right)
(hleftDepth : SameDepth left)
(hrightDepth : SameDepth right)
(hheight : heightOf left = heightOf right) :
let repaired := rotateRight left sep right
(DeletionShape repaired.1 ∧
SameDepth repaired.1 ∧
heightOf repaired.1 = heightOf left) ∧
DeletionShape repaired.2.2 ∧
SameDepth repaired.2.2 ∧
heightOf repaired.2.2 = heightOf right := by
rcases left with ⟨lKeys, lChildren⟩
rcases right with ⟨rKeys, rChildren⟩
cases rKeys with
| nil =>
simp only [rotateRight_nil]
exact
⟨⟨hleftShape, hleftDepth, True.intro⟩,
hrightShape, hrightDepth, True.intro⟩
| cons rHead rTail =>
have hshapeMatch : lChildren = [] ↔ rChildren = [] :=
leaf_iff_of_height_eq hheight
by_cases hleftLeaf : lChildren = []
· have hrightLeaf : rChildren = [] :=
hshapeMatch.mp hleftLeaf
subst lChildren
subst rChildren
simp only [rotateRight_cons, List.take_nil, List.append_nil,
List.drop_nil]
exact
⟨⟨DeletionShape.mk _ _ (Or.inl rfl)
(by intro child hchild; simp at hchild),
SameDepth.leaf _, by simp [heightOf]⟩,
DeletionShape.mk _ _ (Or.inl rfl)
(by intro child hchild; simp at hchild),
SameDepth.leaf _, by simp [heightOf]⟩
· have hrightInternal : rChildren ≠ [] :=
fun hrightLeaf => hleftLeaf (hshapeMatch.mpr hrightLeaf)
obtain ⟨l0, lRest, rfl⟩ :
∃ l0 lRest, lChildren = l0 :: lRest := by
cases lChildren with
| nil => exact absurd rfl hleftLeaf
| cons l0 lRest => exact ⟨l0, lRest, rfl⟩
obtain ⟨r0, rRest, rfl⟩ :
∃ r0 rRest, rChildren = r0 :: rRest := by
cases rChildren with
| nil => exact absurd rfl hrightInternal
| cons r0 rRest => exact ⟨r0, rRest, rfl⟩
have hrightLength :
(r0 :: rRest).length =
(rHead :: rTail).length + 1 :=
hrightShape.childrenRel.resolve_left (by simp)
have hrRestNonempty : rRest ≠ [] := by
intro hnil
subst rRest
simp only [List.length_cons, List.length_nil] at hrightLength
omega
obtain ⟨r1, rSuffix, rfl⟩ :
∃ r1 rSuffix, rRest = r1 :: rSuffix := by
cases rRest with
| nil => exact absurd rfl hrRestNonempty
| cons r1 rSuffix => exact ⟨r1, rSuffix, rfl⟩
have hleftLength :
(l0 :: lRest).length = lKeys.length + 1 :=
hleftShape.childrenRel.resolve_left (by simp)
have hcross : heightOf r0 = heightOf l0 :=
(child_height_bridge hleftDepth hrightDepth hheight
(c := l0) (d := r0) (by simp) (by simp)).symm
have hnewLeftShape :
∀ child ∈ (l0 :: lRest) ++ [r0],
DeletionShape child := by
intro child hchild
rw [List.mem_append] at hchild
rcases hchild with hleftMem | hrightMem
· exact hleftShape.child child hleftMem
· simp only [List.mem_singleton] at hrightMem
subst child
exact hrightShape.child r0 (by simp)
have hnewLeftDepth :
∀ child ∈ (l0 :: lRest) ++ [r0],
SameDepth child := by
intro child hchild
rw [List.mem_append] at hchild
rcases hchild with hleftMem | hrightMem
· exact (sameDepth_iff.mp hleftDepth).1 child hleftMem
· simp only [List.mem_singleton] at hrightMem
subst child
exact (sameDepth_iff.mp hrightDepth).1 r0 (by simp)
have hnewLeftHeight :
∀ child ∈ (l0 :: lRest) ++ [r0],
heightOf child = heightOf l0 := by
intro child hchild
rw [List.mem_append] at hchild
rcases hchild with hleftMem | hrightMem
· exact
(sameDepth_iff.mp hleftDepth).2 child hleftMem l0
(by simp)
· simp only [List.mem_singleton] at hrightMem
subst child
exact hcross
have hnewRightShape :
∀ child ∈ r1 :: rSuffix, DeletionShape child := by
intro child hchild
exact hrightShape.child child (by simp [hchild])
have hnewRightDepth :
∀ child ∈ r1 :: rSuffix, SameDepth child := by
intro child hchild
exact (sameDepth_iff.mp hrightDepth).1 child
(by simp [hchild])
have hnewRightHeight :
∀ child ∈ r1 :: rSuffix,
heightOf child = heightOf r1 := by
intro child hchild
exact
(sameDepth_iff.mp hrightDepth).2 child
(by simp [hchild]) r1 (by simp)
have hleftPacket :=
reassembleInternal_shape_depth_height
hleftDepth (oldWitness := l0) (by simp)
(newKeys := lKeys ++ [sep])
(newChildren := (l0 :: lRest) ++ [r0])
(by
simp only [List.length_append, List.length_cons,
List.length_nil] at hleftLength ⊢
omega)
hnewLeftShape hnewLeftDepth hnewLeftHeight
have hrightPacket :=
reassembleInternal_shape_depth_height
hrightDepth (oldWitness := r1) (by simp)
(newKeys := rTail)
(newChildren := r1 :: rSuffix)
(by
simp only [List.length_cons] at hrightLength ⊢
omega)
hnewRightShape hnewRightDepth hnewRightHeight
simpa [rotateRight_cons] using
And.intro hleftPacket hrightPacket
Borrowing from the left sibling preserves the recursive shape, same depth, and
height of both siblings. This is the shape-only counterpart of
rotateRight_shape_depth_height.
private theorem rotateLeft_shape_depth_height
(left : BTree) (sep : Nat) (right : BTree)
(hleftShape : DeletionShape left)
(hrightShape : DeletionShape right)
(hleftDepth : SameDepth left)
(hrightDepth : SameDepth right)
(hheight : heightOf left = heightOf right) :
let repaired := rotateLeft left sep right
(DeletionShape repaired.1 ∧
SameDepth repaired.1 ∧
heightOf repaired.1 = heightOf left) ∧
DeletionShape repaired.2.2 ∧
SameDepth repaired.2.2 ∧
heightOf repaired.2.2 = heightOf right := by
rcases left with ⟨lKeys, lChildren⟩
rcases right with ⟨rKeys, rChildren⟩
cases lKeys with
| nil =>
simp only [rotateLeft_nil]
exact
⟨⟨hleftShape, hleftDepth, True.intro⟩,
hrightShape, hrightDepth, True.intro⟩
| cons lHead lTail =>
have hshapeMatch : lChildren = [] ↔ rChildren = [] :=
leaf_iff_of_height_eq hheight
by_cases hleftLeaf : lChildren = []
· have hrightLeaf : rChildren = [] :=
hshapeMatch.mp hleftLeaf
subst lChildren
subst rChildren
simp only [rotateLeft_cons, List.take_nil, List.drop_nil,
List.nil_append]
exact
⟨⟨DeletionShape.mk _ _ (Or.inl rfl)
(by intro child hchild; simp at hchild),
SameDepth.leaf _, by simp [heightOf]⟩,
DeletionShape.mk _ _ (Or.inl rfl)
(by intro child hchild; simp at hchild),
SameDepth.leaf _, by simp [heightOf]⟩
· have hrightInternal : rChildren ≠ [] :=
fun hrightLeaf => hleftLeaf (hshapeMatch.mpr hrightLeaf)
have hleftLength :
lChildren.length = (lHead :: lTail).length + 1 :=
hleftShape.childrenRel.resolve_left hleftLeaf
have hrightLength :
rChildren.length = rKeys.length + 1 :=
hrightShape.childrenRel.resolve_left hrightInternal
have hcutPositive : 0 < lChildren.length - 1 := by
simp only [List.length_cons] at hleftLength
omega
have htrimmedLength :
(lChildren.take (lChildren.length - 1)).length =
lChildren.length - 1 := by
rw [List.length_take]
omega
have htrimmedNonempty :
lChildren.take (lChildren.length - 1) ≠ [] := by
intro hnil
rw [hnil] at htrimmedLength
simp only [List.length_nil] at htrimmedLength
omega
obtain ⟨trimmed0, trimmedRest, htrimmedEq⟩ :
∃ trimmed0 trimmedRest,
lChildren.take (lChildren.length - 1) =
trimmed0 :: trimmedRest := by
cases htrimmed :
lChildren.take (lChildren.length - 1) with
| nil => exact absurd htrimmed htrimmedNonempty
| cons trimmed0 trimmedRest =>
exact ⟨trimmed0, trimmedRest, rfl⟩
have htrimmed0Mem :
trimmed0 ∈ lChildren.take (lChildren.length - 1) := by
rw [htrimmedEq]
simp
have htrimmed0Old : trimmed0 ∈ lChildren :=
List.mem_of_mem_take htrimmed0Mem
obtain ⟨right0, rightRest, rfl⟩ :
∃ right0 rightRest, rChildren = right0 :: rightRest := by
cases rChildren with
| nil => exact absurd rfl hrightInternal
| cons right0 rightRest => exact ⟨right0, rightRest, rfl⟩
have hmovedLength :
(lChildren.drop (lChildren.length - 1)).length = 1 := by
rw [List.length_drop]
omega
have htrimmedShape :
∀ child ∈ lChildren.take (lChildren.length - 1),
DeletionShape child := by
intro child hchild
exact hleftShape.child child (List.mem_of_mem_take hchild)
have htrimmedDepth :
∀ child ∈ lChildren.take (lChildren.length - 1),
SameDepth child := by
intro child hchild
exact (sameDepth_iff.mp hleftDepth).1 child
(List.mem_of_mem_take hchild)
have htrimmedHeight :
∀ child ∈ lChildren.take (lChildren.length - 1),
heightOf child = heightOf trimmed0 := by
intro child hchild
exact
(sameDepth_iff.mp hleftDepth).2 child
(List.mem_of_mem_take hchild) trimmed0 htrimmed0Old
have hnewRightShape :
∀ child ∈
lChildren.drop (lChildren.length - 1) ++
(right0 :: rightRest),
DeletionShape child := by
intro child hchild
rw [List.mem_append] at hchild
rcases hchild with hmoved | hrightMem
· exact hleftShape.child child (List.mem_of_mem_drop hmoved)
· exact hrightShape.child child hrightMem
have hnewRightDepth :
∀ child ∈
lChildren.drop (lChildren.length - 1) ++
(right0 :: rightRest),
SameDepth child := by
intro child hchild
rw [List.mem_append] at hchild
rcases hchild with hmoved | hrightMem
· exact (sameDepth_iff.mp hleftDepth).1 child
(List.mem_of_mem_drop hmoved)
· exact (sameDepth_iff.mp hrightDepth).1 child hrightMem
have hnewRightHeight :
∀ child ∈
lChildren.drop (lChildren.length - 1) ++
(right0 :: rightRest),
heightOf child = heightOf right0 := by
intro child hchild
rw [List.mem_append] at hchild
rcases hchild with hmoved | hrightMem
· exact
child_height_bridge hleftDepth hrightDepth hheight
(List.mem_of_mem_drop hmoved) (by simp)
· exact
(sameDepth_iff.mp hrightDepth).2 child hrightMem right0
(by simp)
have hleftPacket :=
reassembleInternal_shape_depth_height
hleftDepth (oldWitness := trimmed0) htrimmed0Old
(newKeys := (lHead :: lTail).dropLast)
(newChildren :=
lChildren.take (lChildren.length - 1))
(by
calc
(lChildren.take (lChildren.length - 1)).length =
lChildren.length - 1 :=
htrimmedLength
_ = (lHead :: lTail).length := by
omega
_ = (lHead :: lTail).dropLast.length + 1 := by
simp)
htrimmedShape htrimmedDepth htrimmedHeight
have hrightPacket :=
reassembleInternal_shape_depth_height
hrightDepth (oldWitness := right0) (by simp)
(newKeys := sep :: rKeys)
(newChildren :=
lChildren.drop (lChildren.length - 1) ++
(right0 :: rightRest))
(by
rw [List.length_append, hmovedLength]
simp only [List.length_cons] at hrightLength ⊢
omega)
hnewRightShape hnewRightDepth hnewRightHeight
simpa [rotateLeft_cons] using
And.intro hleftPacket hrightPacketReplacing adjacent siblings and their separator by one equal-height recursive merge result preserves the parent shape, same depth, and height.
private theorem spliceMerged_shape_depth_height
{j sep : Nat} {ks : List Nat} {cs : List BTree}
{left new : BTree}
(hparentShape : DeletionShape (node ks cs))
(hparentDepth : SameDepth (node ks cs))
(hseparator : ks[j]? = some sep)
(hleft : cs[j]? = some left)
(hnewShape : DeletionShape new)
(hnewDepth : SameDepth new)
(hnewHeight : heightOf new = heightOf left) :
DeletionShape
(node (ks.take j ++ ks.drop (j + 1))
(cs.take j ++ [new] ++ cs.drop (j + 2))) ∧
SameDepth
(node (ks.take j ++ ks.drop (j + 1))
(cs.take j ++ [new] ++ cs.drop (j + 2))) ∧
heightOf
(node (ks.take j ++ ks.drop (j + 1))
(cs.take j ++ [new] ++ cs.drop (j + 2))) =
heightOf (node ks cs) := by
obtain ⟨hjKey, _⟩ :=
List.getElem?_eq_some_iff.mp hseparator
obtain ⟨hjChild, _⟩ :=
List.getElem?_eq_some_iff.mp hleft
have hleftMem : left ∈ cs :=
List.mem_iff_getElem?.mpr ⟨j, hleft⟩
have hcsNonempty : cs ≠ [] := by
intro hnil
subst cs
simp at hleft
have hchildrenLength : cs.length = ks.length + 1 :=
hparentShape.childrenRel.resolve_left hcsNonempty
have htakeKeysLength : (ks.take j).length = j := by
rw [List.length_take, Nat.min_eq_left (Nat.le_of_lt hjKey)]
have htakeChildrenLength : (cs.take j).length = j := by
rw [List.length_take, Nat.min_eq_left (Nat.le_of_lt hjChild)]
have houtChildrenShape :
∀ child ∈ cs.take j ++ [new] ++ cs.drop (j + 2),
DeletionShape child := by
intro child hchild
simp only [List.mem_append, List.mem_singleton] at hchild
rcases hchild with hprefixOrNew | hsuffix
· rcases hprefixOrNew with hprefix | hnew
· exact hparentShape.child child (List.mem_of_mem_take hprefix)
· subst child
exact hnewShape
· exact hparentShape.child child (List.mem_of_mem_drop hsuffix)
have houtChildrenDepth :
∀ child ∈ cs.take j ++ [new] ++ cs.drop (j + 2),
SameDepth child := by
intro child hchild
simp only [List.mem_append, List.mem_singleton] at hchild
rcases hchild with hprefixOrNew | hsuffix
· rcases hprefixOrNew with hprefix | hnew
· exact (sameDepth_iff.mp hparentDepth).1 child
(List.mem_of_mem_take hprefix)
· subst child
exact hnewDepth
· exact (sameDepth_iff.mp hparentDepth).1 child
(List.mem_of_mem_drop hsuffix)
have houtChildrenHeight :
∀ child ∈ cs.take j ++ [new] ++ cs.drop (j + 2),
heightOf child = heightOf left := by
intro child hchild
simp only [List.mem_append, List.mem_singleton] at hchild
rcases hchild with hprefixOrNew | hsuffix
· rcases hprefixOrNew with hprefix | hnew
· exact (sameDepth_iff.mp hparentDepth).2 child
(List.mem_of_mem_take hprefix) left hleftMem
· subst child
exact hnewHeight
· exact (sameDepth_iff.mp hparentDepth).2 child
(List.mem_of_mem_drop hsuffix) left hleftMem
exact
reassembleInternal_shape_depth_height
hparentDepth hleftMem
(newKeys := ks.take j ++ ks.drop (j + 1))
(newChildren := cs.take j ++ [new] ++ cs.drop (j + 2))
(by
simp only [List.length_append, htakeKeysLength,
htakeChildrenLength, List.length_cons, List.length_nil,
List.length_drop]
omega)
houtChildrenShape houtChildrenDepth houtChildrenHeightA looked-up child inherits recursive shape and same depth from its parent.
private theorem child_shape_depth_of_getElem?
{i : Nat} {ks : List Nat} {cs : List BTree} {child : BTree}
(hshape : DeletionShape (node ks cs))
(hdepth : SameDepth (node ks cs))
(hchild : cs[i]? = some child) :
DeletionShape child ∧ SameDepth child := by
have hchildMem : child ∈ cs :=
List.mem_iff_getElem?.mpr ⟨i, hchild⟩
exact
⟨hshape.child child hchildMem,
(sameDepth_iff.mp hdepth).1 child hchildMem⟩Adjacent looked-up children inherit shape and same depth and have equal raw height.
private theorem adjacentChildren_shape_depth_height
{i : Nat} {ks : List Nat} {cs : List BTree}
{left right : BTree}
(hshape : DeletionShape (node ks cs))
(hdepth : SameDepth (node ks cs))
(hleft : cs[i]? = some left)
(hright : cs[i + 1]? = some right) :
DeletionShape left ∧ SameDepth left ∧
DeletionShape right ∧ SameDepth right ∧
heightOf left = heightOf right := by
have hleftMem : left ∈ cs :=
List.mem_iff_getElem?.mpr ⟨i, hleft⟩
have hrightMem : right ∈ cs :=
List.mem_iff_getElem?.mpr ⟨i + 1, hright⟩
exact
⟨hshape.child left hleftMem,
(sameDepth_iff.mp hdepth).1 left hleftMem,
hshape.child right hrightMem,
(sameDepth_iff.mp hdepth).1 right hrightMem,
(sameDepth_iff.mp hdepth).2 left hleftMem right hrightMem⟩
For a non-leaf recursive shape, findChild always selects an existing child.
private theorem DeletionShape.findChild_lt
{ks : List Nat} {cs : List BTree}
(hshape : DeletionShape (node ks cs))
(hchildren : cs ≠ []) (x : Nat) :
findChild ks x < cs.length := by
have hlength : cs.length = ks.length + 1 :=
hshape.childrenRel.resolve_left hchildren
have hfind := findChild_le ks x
omega
An existing non-leaf DeletionShape node cannot fail to return the child
selected by findChild.
private theorem DeletionShape.findChild_none_absurd
{ks : List Nat} {cs : List BTree} (hshape : DeletionShape (node ks cs))
(hchildren : cs ≠ []) {x : Nat}
(hnone : cs[findChild ks x]? = none) : False := by
obtain ⟨child, hchild⟩ :=
getElem?_exists_of_lt (hshape.findChild_lt hchildren x)
rw [hnone] at hchild
simp at hchild
An existing separator in a non-leaf DeletionShape node has a child at the
same index.
private theorem DeletionShape.childAtKey_none_absurd
{j sep : Nat} {ks : List Nat} {cs : List BTree}
(hshape : DeletionShape (node ks cs))
(hchildren : cs ≠ []) (hkey : ks[j]? = some sep)
(hnone : cs[j]? = none) : False := by
have hlength := hshape.childrenRel.resolve_left hchildren
have hj := (List.getElem?_eq_some_iff.mp hkey).1
obtain ⟨child, hchild⟩ :=
getElem?_exists_of_lt (xs := cs) (i := j) (by omega)
rw [hnone] at hchild
simp at hchild
An existing separator in a non-leaf DeletionShape node has a right child at
the following index.
private theorem DeletionShape.rightChildAtKey_none_absurd
{j sep : Nat} {ks : List Nat} {cs : List BTree}
(hshape : DeletionShape (node ks cs))
(hchildren : cs ≠ []) (hkey : ks[j]? = some sep)
(hnone : cs[j + 1]? = none) : False := by
have hlength := hshape.childrenRel.resolve_left hchildren
have hj := (List.getElem?_eq_some_iff.mp hkey).1
obtain ⟨child, hchild⟩ :=
getElem?_exists_of_lt (xs := cs) (i := j + 1) (by omega)
rw [hnone] at hchild
simp at hchild
An existing right child in a DeletionShape node cannot lack the separator
immediately to its left.
private theorem DeletionShape.separator_none_of_rightChild_absurd
{j : Nat} {ks : List Nat} {cs : List BTree} {right : BTree}
(hshape : DeletionShape (node ks cs))
(hright : cs[j + 1]? = some right) (hnone : ks[j]? = none) : False := by
have hchildren : cs ≠ [] := by
intro hnil
subst cs
simp at hright
have hlength := hshape.childrenRel.resolve_left hchildren
have hjRight := (List.getElem?_eq_some_iff.mp hright).1
obtain ⟨sep, hsep⟩ :=
getElem?_exists_of_lt (xs := ks) (i := j) (by omega)
rw [hnone] at hsep
simp at hsepA nonempty list cannot have no element at index zero.
private theorem getElem?_zero_none_absurd {α : Type*} {xs : List α}
(hne : xs ≠ []) (hnone : xs[0]? = none) : False := by
cases xs with
| nil => exact hne rfl
| cons head tail => simp at hnoneThe shape-only induction theorem for raw composed deletion. It deliberately tracks no key ordering, occupancy, minimum degree, or root flag.
private theorem composedDelete_shape_depth_height
(t x : Nat) (tr : BTree) :
DeletionShape tr → SameDepth tr →
DeletionShape (composedDelete t x tr) ∧
SameDepth (composedDelete t x tr) ∧
heightOf (composedDelete t x tr) = heightOf tr := by
induction x, tr using composedDelete.induct (t := t) <;>
intro hshape hdepth
case case1 =>
rename_i x ks cs hleaf
have hcs : cs = [] :=
List.isEmpty_iff.mp hleaf
subst cs
simp only [composedDelete, List.isEmpty_nil, ↓reduceIte]
exact
⟨DeletionShape.mk _ _ (Or.inl rfl)
(by intro child hchild; simp at hchild),
SameDepth.leaf _, by simp [heightOf]⟩
case case2 =>
rename_i ks cs hnonempty sep left right hleftReady i hpos ki
hsep hleft hright ih
simp only [i] at hpos
simp only [ki, i] at hsep hleft hright
have hleftPacket :=
child_shape_depth_of_getElem? hshape hdepth hleft
have hrec := ih hleftPacket.1 hleftPacket.2
have hkeys :=
replaceKeys_shape_depth_height hshape hdepth
(newKeys := ks.set (findChild ks sep - 1) (maxKey left))
(by simp)
have hchild :=
replaceChild_shape_depth_height hkeys.1 hkeys.2.1 hleft
hrec.1 hrec.2.1 hrec.2.2
have hpacket :
DeletionShape
(node (ks.set (findChild ks sep - 1) (maxKey left))
(cs.set (findChild ks sep - 1)
(composedDelete t (maxKey left) left))) ∧
SameDepth
(node (ks.set (findChild ks sep - 1) (maxKey left))
(cs.set (findChild ks sep - 1)
(composedDelete t (maxKey left) left))) ∧
heightOf
(node (ks.set (findChild ks sep - 1) (maxKey left))
(cs.set (findChild ks sep - 1)
(composedDelete t (maxKey left) left))) =
heightOf (node ks cs) :=
⟨hchild.1, hchild.2.1, hchild.2.2.trans hkeys.2.2⟩
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t sep (node ks cs) =
node (ks.set (findChild ks sep - 1) (maxKey left))
(cs.set (findChild ks sep - 1)
(composedDelete t (maxKey left) left)) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
rw [hsep, hleft, hright]
simp [hleftReady]
rw [hdeleteEq]
exact hpacket
case case3 =>
rename_i ks cs hnonempty sep left right hleftNotReady hrightReady
i hpos ki hsep hleft hright ih
simp only [i] at hpos
simp only [ki, i] at hsep hleft hright
have hrightPacket :=
child_shape_depth_of_getElem? hshape hdepth hright
have hrec := ih hrightPacket.1 hrightPacket.2
have hkeys :=
replaceKeys_shape_depth_height hshape hdepth
(newKeys := ks.set (findChild ks sep - 1) (minKey right))
(by simp)
have hchild :=
replaceChild_shape_depth_height hkeys.1 hkeys.2.1 hright
hrec.1 hrec.2.1 hrec.2.2
have hpacket :
DeletionShape
(node (ks.set (findChild ks sep - 1) (minKey right))
(cs.set (findChild ks sep - 1 + 1)
(composedDelete t (minKey right) right))) ∧
SameDepth
(node (ks.set (findChild ks sep - 1) (minKey right))
(cs.set (findChild ks sep - 1 + 1)
(composedDelete t (minKey right) right))) ∧
heightOf
(node (ks.set (findChild ks sep - 1) (minKey right))
(cs.set (findChild ks sep - 1 + 1)
(composedDelete t (minKey right) right))) =
heightOf (node ks cs) := by
simpa using
And.intro hchild.1
(And.intro hchild.2.1
(hchild.2.2.trans hkeys.2.2))
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t sep (node ks cs) =
node (ks.set (findChild ks sep - 1) (minKey right))
(cs.set (findChild ks sep - 1 + 1)
(composedDelete t (minKey right) right)) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
rw [hsep, hleft, hright]
simp [hleftNotReady, hrightReady]
rw [hdeleteEq]
exact hpacket
case case4 =>
rename_i ks cs hnonempty sep left right hleftNotReady
hrightNotReady merged i hpos ki hsep hleft hright ih
simp only [i] at hpos
simp only [ki, i] at hsep hleft hright
have hadjacent :=
adjacentChildren_shape_depth_height hshape hdepth hleft hright
have hmerged :=
mergeNodes_shape_depth_height (sep := sep)
hadjacent.1 hadjacent.2.2.1
hadjacent.2.1 hadjacent.2.2.2.1 hadjacent.2.2.2.2
have hrec :=
ih (by simpa [merged] using hmerged.1)
(by simpa [merged] using hmerged.2.1)
have hsplice :=
spliceMerged_shape_depth_height hshape hdepth hsep hleft
hrec.1 hrec.2.1
(hrec.2.2.trans (by simpa [merged] using hmerged.2.2))
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t sep (node ks cs) =
node
(ks.take (findChild ks sep - 1) ++
ks.drop (findChild ks sep - 1 + 1))
(cs.take (findChild ks sep - 1) ++
[composedDelete t sep merged] ++
cs.drop (findChild ks sep - 1 + 2)) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
rw [hsep, hleft, hright]
simp [hleftNotReady, hrightNotReady, merged]
rw [hdeleteEq]
exact hsplice
case case7 =>
rename_i x ks cs hnonempty i hpos ki oldSep hsep hne child hchild
hchildReady ih
simp only [i] at hpos hchild
simp only [ki, i] at hsep
have hchildPacket :=
child_shape_depth_of_getElem? hshape hdepth hchild
have hrec := ih hchildPacket.1 hchildPacket.2
have hpacket :=
replaceChild_shape_depth_height hshape hdepth hchild
hrec.1 hrec.2.1 hrec.2.2
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t x (node ks cs) =
node ks (cs.set (findChild ks x)
(composedDelete t x child)) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
rw [hsep, hchild]
simp [hchildReady]
exact fun heq => (hne heq).elim
rw [hdeleteEq]
exact hpacket
case case8 =>
rename_i x ks cs hnonempty i hpos ki oldSep hsepOld hne child
hchild hchildNotReady left hleft hleftReady sep hsep ih
simp only [i] at hpos hchild hleft hsep
simp only [ki, i] at hsepOld
have holdSepEq : oldSep = sep :=
Option.some.inj (hsepOld.symm.trans hsep)
subst oldSep
have hchildAt :
cs[(findChild ks x - 1) + 1]? = some child := by
simpa [show findChild ks x - 1 + 1 = findChild ks x by omega]
using hchild
have hadjacent :=
adjacentChildren_shape_depth_height hshape hdepth hleft hchildAt
have hrotated :=
rotateLeft_shape_depth_height left sep child hadjacent.1
hadjacent.2.2.1 hadjacent.2.1 hadjacent.2.2.2.1
hadjacent.2.2.2.2
dsimp only at hrotated
have hrec := ih hrotated.2.1 hrotated.2.2.1
have hkeys :=
replaceKeys_shape_depth_height hshape hdepth
(newKeys :=
ks.set (findChild ks x - 1)
(rotateLeft left sep child).2.1)
(by simp)
have hleftInstalled :=
replaceChild_shape_depth_height hkeys.1 hkeys.2.1 hleft
hrotated.1.1 hrotated.1.2.1 hrotated.1.2.2
have hchildAfter :
(cs.set (findChild ks x - 1)
(rotateLeft left sep child).1)[findChild ks x]? =
some child := by
rw [List.getElem?_set_ne (by omega :
findChild ks x - 1 ≠ findChild ks x)]
exact hchild
have hchildInstalled :=
replaceChild_shape_depth_height hleftInstalled.1
hleftInstalled.2.1 hchildAfter hrec.1 hrec.2.1
(hrec.2.2.trans hrotated.2.2.2)
have hpacket :
DeletionShape
(node
(ks.set (findChild ks x - 1)
(rotateLeft left sep child).2.1)
((cs.set (findChild ks x - 1)
(rotateLeft left sep child).1).set
(findChild ks x)
(composedDelete t x
(rotateLeft left sep child).2.2))) ∧
SameDepth
(node
(ks.set (findChild ks x - 1)
(rotateLeft left sep child).2.1)
((cs.set (findChild ks x - 1)
(rotateLeft left sep child).1).set
(findChild ks x)
(composedDelete t x
(rotateLeft left sep child).2.2))) ∧
heightOf
(node
(ks.set (findChild ks x - 1)
(rotateLeft left sep child).2.1)
((cs.set (findChild ks x - 1)
(rotateLeft left sep child).1).set
(findChild ks x)
(composedDelete t x
(rotateLeft left sep child).2.2))) =
heightOf (node ks cs) :=
⟨hchildInstalled.1, hchildInstalled.2.1,
hchildInstalled.2.2.trans
(hleftInstalled.2.2.trans hkeys.2.2)⟩
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t x (node ks cs) =
node
(ks.set (findChild ks x - 1)
(rotateLeft left sep child).2.1)
((cs.set (findChild ks x - 1)
(rotateLeft left sep child).1).set
(findChild ks x)
(composedDelete t x
(rotateLeft left sep child).2.2)) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
rw [hsepOld, hchild, hleft]
simp [hne, hchildNotReady, hleftReady]
rw [hdeleteEq]
exact hpacket
case case10 =>
rename_i x ks cs hnonempty i hpos ki oldSep hsepOld hne child
hchild hchildNotReady left hleft hleftNotReady right hright
hrightReady sep hsep ih
simp only [i] at hpos hchild hleft hright hsep
simp only [ki, i] at hsepOld
have hadjacent :=
adjacentChildren_shape_depth_height hshape hdepth hchild hright
have hrotated :=
rotateRight_shape_depth_height child sep right hadjacent.1
hadjacent.2.2.1 hadjacent.2.1 hadjacent.2.2.2.1
hadjacent.2.2.2.2
dsimp only at hrotated
have hrec := ih hrotated.1.1 hrotated.1.2.1
have hkeys :=
replaceKeys_shape_depth_height hshape hdepth
(newKeys :=
ks.set (findChild ks x)
(rotateRight child sep right).2.1)
(by simp)
have hchildInstalled :=
replaceChild_shape_depth_height hkeys.1 hkeys.2.1 hchild
hrec.1 hrec.2.1 (hrec.2.2.trans hrotated.1.2.2)
have hrightAfter :
(cs.set (findChild ks x)
(composedDelete t x
(rotateRight child sep right).1))[findChild ks x + 1]? =
some right := by
rw [List.getElem?_set_ne (by omega :
findChild ks x ≠ findChild ks x + 1)]
exact hright
have hrightInstalled :=
replaceChild_shape_depth_height hchildInstalled.1
hchildInstalled.2.1 hrightAfter hrotated.2.1
hrotated.2.2.1 hrotated.2.2.2
have hpacket :=
And.intro hrightInstalled.1
(And.intro hrightInstalled.2.1
(hrightInstalled.2.2.trans
(hchildInstalled.2.2.trans hkeys.2.2)))
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t x (node ks cs) =
node
(ks.set (findChild ks x)
(rotateRight child sep right).2.1)
((cs.set (findChild ks x)
(composedDelete t x
(rotateRight child sep right).1)).set
(findChild ks x + 1)
(rotateRight child sep right).2.2) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
rw [hsepOld, hchild, hleft, hright, hsep]
simp [hne, hchildNotReady, hleftNotReady, hrightReady]
rw [hdeleteEq]
exact hpacket
case case12 =>
rename_i x ks cs hnonempty i hpos ki oldSep hsepOld hne child
hchild hchildNotReady left hleft hleftNotReady rightSib
hrightSib hrightNotReady sep hsep ih
simp only [i] at hpos hchild hleft hrightSib hsep
simp only [ki, i] at hsepOld
have holdSepEq : oldSep = sep :=
Option.some.inj (hsepOld.symm.trans hsep)
subst oldSep
have hchildAt :
cs[(findChild ks x - 1) + 1]? = some child := by
simpa [show findChild ks x - 1 + 1 = findChild ks x by omega]
using hchild
have hadjacent :=
adjacentChildren_shape_depth_height hshape hdepth hleft hchildAt
have hmerged :=
mergeNodes_shape_depth_height (sep := sep)
hadjacent.1 hadjacent.2.2.1
hadjacent.2.1 hadjacent.2.2.2.1 hadjacent.2.2.2.2
have hrec := ih hmerged.1 hmerged.2.1
have hsplice :=
spliceMerged_shape_depth_height hshape hdepth hsep hleft
hrec.1 hrec.2.1 (hrec.2.2.trans hmerged.2.2)
have hpacket :
DeletionShape
(node
(ks.take (findChild ks x - 1) ++
ks.drop (findChild ks x))
(cs.take (findChild ks x - 1) ++
[composedDelete t x (mergeNodes left sep child)] ++
cs.drop (findChild ks x + 1))) ∧
SameDepth
(node
(ks.take (findChild ks x - 1) ++
ks.drop (findChild ks x))
(cs.take (findChild ks x - 1) ++
[composedDelete t x (mergeNodes left sep child)] ++
cs.drop (findChild ks x + 1))) ∧
heightOf
(node
(ks.take (findChild ks x - 1) ++
ks.drop (findChild ks x))
(cs.take (findChild ks x - 1) ++
[composedDelete t x (mergeNodes left sep child)] ++
cs.drop (findChild ks x + 1))) =
heightOf (node ks cs) := by
simpa [show findChild ks x - 1 + 1 = findChild ks x by omega,
show findChild ks x - 1 + 2 = findChild ks x + 1 by omega]
using hsplice
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t x (node ks cs) =
node
(ks.take (findChild ks x - 1) ++ ks.drop (findChild ks x))
(cs.take (findChild ks x - 1) ++
[composedDelete t x (mergeNodes left sep child)] ++
cs.drop (findChild ks x + 1)) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
rw [hsepOld, hchild, hleft, hrightSib]
simp [hne, hchildNotReady, hleftNotReady, hrightNotReady]
rw [hdeleteEq]
exact hpacket
case case14 =>
rename_i x ks cs hnonempty i hpos ki oldSep hsepOld hne child
hchild hchildNotReady left hleft hleftNotReady hrightNone
sep hsep ih
simp only [i] at hpos hchild hleft hrightNone hsep
simp only [ki, i] at hsepOld
have holdSepEq : oldSep = sep :=
Option.some.inj (hsepOld.symm.trans hsep)
subst oldSep
have hchildAt :
cs[(findChild ks x - 1) + 1]? = some child := by
simpa [show findChild ks x - 1 + 1 = findChild ks x by omega]
using hchild
have hadjacent :=
adjacentChildren_shape_depth_height hshape hdepth hleft hchildAt
have hmerged :=
mergeNodes_shape_depth_height (sep := sep)
hadjacent.1 hadjacent.2.2.1
hadjacent.2.1 hadjacent.2.2.2.1 hadjacent.2.2.2.2
have hrec := ih hmerged.1 hmerged.2.1
have hsplice :=
spliceMerged_shape_depth_height hshape hdepth hsep hleft
hrec.1 hrec.2.1 (hrec.2.2.trans hmerged.2.2)
have hpacket :
DeletionShape
(node
(ks.take (findChild ks x - 1) ++
ks.drop (findChild ks x))
(cs.take (findChild ks x - 1) ++
[composedDelete t x (mergeNodes left sep child)] ++
cs.drop (findChild ks x + 1))) ∧
SameDepth
(node
(ks.take (findChild ks x - 1) ++
ks.drop (findChild ks x))
(cs.take (findChild ks x - 1) ++
[composedDelete t x (mergeNodes left sep child)] ++
cs.drop (findChild ks x + 1))) ∧
heightOf
(node
(ks.take (findChild ks x - 1) ++
ks.drop (findChild ks x))
(cs.take (findChild ks x - 1) ++
[composedDelete t x (mergeNodes left sep child)] ++
cs.drop (findChild ks x + 1))) =
heightOf (node ks cs) := by
simpa [show findChild ks x - 1 + 1 = findChild ks x by omega,
show findChild ks x - 1 + 2 = findChild ks x + 1 by omega]
using hsplice
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t x (node ks cs) =
node
(ks.take (findChild ks x - 1) ++ ks.drop (findChild ks x))
(cs.take (findChild ks x - 1) ++
[composedDelete t x (mergeNodes left sep child)] ++
cs.drop (findChild ks x + 1)) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
rw [hsepOld, hchild, hleft, hrightNone]
simp [hne, hchildNotReady, hleftNotReady]
rw [hdeleteEq]
exact hpacket
case case29 =>
rename_i x ks cs hnonempty i hnotPos child hchild hchildReady ih
simp only [i] at hnotPos hchild
have hchildPacket :=
child_shape_depth_of_getElem? hshape hdepth hchild
have hrec := ih hchildPacket.1 hchildPacket.2
have hpacket :=
replaceChild_shape_depth_height hshape hdepth hchild
hrec.1 hrec.2.1 hrec.2.2
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t x (node ks cs) =
node ks (cs.set 0 (composedDelete t x child)) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte]
rw [hchild]
simp [hchildReady]
exact fun hpos => (hnotPos hpos).elim
rw [hdeleteEq]
exact hpacket
case case30 =>
rename_i x ks cs hnonempty i hnotPos child hchild hchildNotReady
right hright hrightReady sep hsep ih
simp only [i] at hnotPos hchild hright hsep
have hadjacent :=
adjacentChildren_shape_depth_height hshape hdepth hchild hright
have hrotated :=
rotateRight_shape_depth_height child sep right hadjacent.1
hadjacent.2.2.1 hadjacent.2.1 hadjacent.2.2.2.1
hadjacent.2.2.2.2
dsimp only at hrotated
have hrec := ih hrotated.1.1 hrotated.1.2.1
have hkeys :=
replaceKeys_shape_depth_height hshape hdepth
(newKeys := ks.set 0 (rotateRight child sep right).2.1)
(by simp)
have hchildInstalled :=
replaceChild_shape_depth_height hkeys.1 hkeys.2.1 hchild
hrec.1 hrec.2.1 (hrec.2.2.trans hrotated.1.2.2)
have hrightAfter :
(cs.set 0
(composedDelete t x
(rotateRight child sep right).1))[1]? = some right := by
rw [List.getElem?_set_ne (by decide : 0 ≠ 1)]
exact hright
have hrightInstalled :=
replaceChild_shape_depth_height hchildInstalled.1
hchildInstalled.2.1 hrightAfter hrotated.2.1
hrotated.2.2.1 hrotated.2.2.2
have hpacket :=
And.intro hrightInstalled.1
(And.intro hrightInstalled.2.1
(hrightInstalled.2.2.trans
(hchildInstalled.2.2.trans hkeys.2.2)))
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t x (node ks cs) =
node (ks.set 0 (rotateRight child sep right).2.1)
((cs.set 0
(composedDelete t x
(rotateRight child sep right).1)).set 1
(rotateRight child sep right).2.2) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte]
rw [dif_neg hnotPos]
rw [hchild]
simp only
rw [dif_neg hchildNotReady]
rw [hright]
simp only
rw [dif_pos hrightReady]
rw [hsep]
rw [hdeleteEq]
exact hpacket
case case32 =>
rename_i x ks cs hnonempty i hnotPos child hchild hchildNotReady
right hright hrightNotReady sep hsep ih
simp only [i] at hnotPos hchild hright hsep
have hadjacent :=
adjacentChildren_shape_depth_height hshape hdepth hchild hright
have hmerged :=
mergeNodes_shape_depth_height (sep := sep)
hadjacent.1 hadjacent.2.2.1
hadjacent.2.1 hadjacent.2.2.2.1 hadjacent.2.2.2.2
have hrec := ih hmerged.1 hmerged.2.1
have hsplice :=
spliceMerged_shape_depth_height hshape hdepth hsep hchild
hrec.1 hrec.2.1 (hrec.2.2.trans hmerged.2.2)
have hpacket :
DeletionShape
(node (ks.drop 1)
([composedDelete t x (mergeNodes child sep right)] ++
cs.drop 2)) ∧
SameDepth
(node (ks.drop 1)
([composedDelete t x (mergeNodes child sep right)] ++
cs.drop 2)) ∧
heightOf
(node (ks.drop 1)
([composedDelete t x (mergeNodes child sep right)] ++
cs.drop 2)) =
heightOf (node ks cs) := by
simpa using hsplice
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t x (node ks cs) =
node (ks.drop 1)
([composedDelete t x (mergeNodes child sep right)] ++
cs.drop 2) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte]
rw [dif_neg hnotPos]
rw [hchild]
simp only
rw [dif_neg hchildNotReady]
rw [hright]
simp only
rw [dif_neg hrightNotReady]
rw [hsep]
rw [hdeleteEq]
exact hpacket
case case34 =>
rename_i x ks cs hnonempty i hnotPos child hchild hchildNotReady
hrightNone ih
simp only [i] at hnotPos hchild hrightNone
have hchildPacket :=
child_shape_depth_of_getElem? hshape hdepth hchild
have hrec := ih hchildPacket.1 hchildPacket.2
have hpacket :=
replaceChild_shape_depth_height hshape hdepth hchild
hrec.1 hrec.2.1 hrec.2.2
have hnotLeaf : cs.isEmpty = false :=
Bool.eq_false_of_not_eq_true hnonempty
have hdeleteEq :
composedDelete t x (node ks cs) =
node ks (cs.set 0 (composedDelete t x child)) := by
rw [composedDelete]
simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte]
rw [dif_neg hnotPos]
rw [hchild]
simp only
rw [dif_neg hchildNotReady]
rw [hrightNone]
rw [hdeleteEq]
exact hpacket
all_goals
exfalso
try dsimp only at *
first
| apply findChild_predecessor_none_absurd <;> assumption
| apply hshape.rightChildAtKey_none_absurd
· intro hnil; subst_vars; simp_all
· assumption
· assumption
| apply hshape.childAtKey_none_absurd
· intro hnil; subst_vars; simp_all
· assumption
· assumption
| apply hshape.separator_none_of_rightChild_absurd <;> assumption
| apply hshape.findChild_none_absurd
· intro hnil; subst_vars; simp_all
· assumption
| apply getElem?_zero_none_absurd
· intro hnil; simp_all
· assumptionRaw composed deletion preserves equal leaf depth and height from recursive child-count shape and the same-depth invariant alone.
lemma composedDelete_sameDepth_height
(t x : Nat) {tr : BTree}
(hbounded : ChildBounded tr) (hdepth : SameDepth tr) :
SameDepth (composedDelete t x tr) ∧
heightOf (composedDelete t x tr) = heightOf tr := by
have hresult :=
composedDelete_shape_depth_height t x tr
(deletionShape_of_childBounded tr hbounded) hdepth
exact ⟨hresult.2.1, hresult.2.2⟩end CLRS.Chapter18.BTreeCLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.Sorted
B-tree deletion: sortedness projection
This submodule retains the public composedDelete_sorted name as a
small projection from the bundled raw-deletion preservation theorem.
namespace CLRSnamespace Chapter18namespace BTreeRaw deletion preserves recursive key sortedness for a structurally well-formed input node.
lemma composedDelete_sorted
(t x : Nat) (ht : 2 ≤ t) (tr : BTree) {isRoot : Bool}
(hinv : NodeWF t isRoot tr) :
Sorted (composedDelete t x tr) := by
exact
(composedDelete_rootResult t x ht (hinv.asRoot ht)).2.1.1end BTreeend Chapter18end CLRSCLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.Subset
B-tree deletion: key-set subset and key-bound projections
This submodule exposes the key-set component of the bundled raw-deletion
preservation theorem. The input carries a complete NodeWF packet:
without that premise, deletion on malformed trees may synthesize a default
separator key.
namespace CLRSnamespace Chapter18namespace BTreeResult keys come from the input tree
Every key represented by raw deletion was already represented by the input.
The root view is sufficient because NodeWF.asRoot weakens non-root
occupancy while preserving the other structural invariants.
lemma keysOf_composedDelete_subset
(t x : Nat) (ht : 2 ≤ t) (tr : BTree) {isRoot : Bool}
(hinv : NodeWF t isRoot tr) (k : Nat)
(hk : k ∈ keysOf (composedDelete t x tr)) :
k ∈ keysOf tr := by
exact
(composedDelete_rootResult t x ht (hinv.asRoot ht)).1 k hkKey-bound transfer
Transfer a lower key bound through raw deletion. The complete invariant packet supplies the premise needed by the subset theorem.
lemma composedDelete_key_bound_lo
(t x : Nat) (ht : 2 ≤ t) (tr : BTree) {isRoot : Bool}
(hinv : NodeWF t isRoot tr) (lo : Nat)
(hlo : ∀ k ∈ keysOf tr, lo ≤ k) :
∀ k ∈ keysOf (composedDelete t x tr), lo ≤ k :=
fun k hk =>
hlo k (keysOf_composedDelete_subset t x ht tr hinv k hk)Transfer an upper key bound through raw deletion.
lemma composedDelete_key_bound_hi
(t x : Nat) (ht : 2 ≤ t) (tr : BTree) {isRoot : Bool}
(hinv : NodeWF t isRoot tr) (hi : Nat)
(hhi : ∀ k ∈ keysOf tr, k ≤ hi) :
∀ k ∈ keysOf (composedDelete t x tr), k ≤ hi :=
fun k hk =>
hhi k (keysOf_composedDelete_subset t x ht tr hinv k hk)end BTreeend Chapter18end CLRSCLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.WellFormed
Root-normalized B-tree deletion
Raw composedDelete may return an empty root with one child, so it
does not preserve the root-specialized WellFormed predicate directly.
The public root operation composedDeleteRoot contracts that one
transient level. This module combines its key-subset, height, and structural
postconditions with exact erase-one key-bag semantics. Under global key
uniqueness, it also proves deleted-key absence and compatibility with the
specification-level deletion and membership search.
namespace CLRSnamespace Chapter18namespace BTreeRoot-normalized deletion represents only keys from the input tree.
theorem composedDeleteRoot_keys_subset
(t x : Nat) (ht : 2 ≤ t) {tr : BTree}
(hwf : WellFormed t tr) :
KeysSubset (composedDeleteRoot t x tr) tr := by
have hraw :=
(composedDelete_rootResult t x ht hwf).1
intro k hk
apply hraw k
simpa [composedDeleteRoot, keysOf_normalizeRoot] using hkRoot normalization either preserves the raw height or contracts exactly one root level.
theorem composedDeleteRoot_height
(t x : Nat) (ht : 2 ≤ t) {tr : BTree}
(hwf : WellFormed t tr) :
heightOf (composedDeleteRoot t x tr) = heightOf tr ∨
heightOf (composedDeleteRoot t x tr) + 1 = heightOf tr := by
have hraw :=
(composedDelete_rootResult t x ht hwf).2.2
have hnormalize :=
heightOf_normalizeRoot (composedDelete t x tr)
change
heightOf (normalizeRoot (composedDelete t x tr)) = heightOf tr ∨
heightOf (normalizeRoot (composedDelete t x tr)) + 1 =
heightOf tr
rcases hnormalize with hsame | hcontract
· exact Or.inl (hsame.trans hraw)
· exact Or.inr (hcontract.trans hraw)The root-normalized CLRS deletion operation preserves the complete well-formedness invariant.
theorem composedDeleteRoot_wellFormed
(t x : Nat) (ht : 2 ≤ t) {tr : BTree}
(hwf : WellFormed t tr) :
WellFormed t (composedDeleteRoot t x tr) := by
have hraw :=
(composedDelete_rootResult t x ht hwf).2.1
simpa [composedDeleteRoot] using
(normalizeRoot_wellFormed ht hraw)Root normalization preserves the erase-one key-bag semantics of raw deletion.
theorem composedDeleteRoot_keyBag
(t x : Nat) (ht : 2 ≤ t) {tr : BTree}
(hwf : WellFormed t tr) :
keyBag (composedDeleteRoot t x tr) =
(keyBag tr).erase x := by
have hraw :=
composedDelete_keyBag t x ht hwf.nodeWF
simpa only [composedDeleteRoot, keyBag, keysOf_normalizeRoot] using hrawRoot-normalized deletion preserves membership of every key distinct from the requested key, without requiring key uniqueness.
theorem composedDeleteRoot_mem_iff_of_ne
(t x y : Nat) (ht : 2 ≤ t) {tr : BTree}
(hwf : WellFormed t tr) (hyx : y ≠ x) :
mem y (composedDeleteRoot t x tr) ↔ mem y tr := by
have hraw :=
composedDelete_mem_iff_of_ne t x y ht hwf.nodeWF hyx
simpa only [composedDeleteRoot, mem, keysOf_normalizeRoot] using hrawWhen represented keys are unique, root-normalized deletion leaves no occurrence of the requested key.
theorem composedDeleteRoot_not_mem
(t x : Nat) (ht : 2 ≤ t) {tr : BTree}
(hwf : WellFormedUnique t tr) :
¬ mem x (composedDeleteRoot t x tr) := by
have hbag :=
composedDeleteRoot_keyBag t x ht hwf.1
have hnodup : (keyBag tr).Nodup := by
simpa only [keyBag] using
(Multiset.coe_nodup.mpr hwf.2)
intro hx
have hxBag :
x ∈ keyBag (composedDeleteRoot t x tr) := by
simpa only [mem, keyBag, Multiset.mem_coe] using hx
rw [hbag] at hxBag
exact hnodup.notMem_erase hxBagUnder key uniqueness, membership after root-normalized deletion is exactly old membership restricted to keys different from the requested key.
theorem composedDeleteRoot_mem_iff
(t x y : Nat) (ht : 2 ≤ t) {tr : BTree}
(hwf : WellFormedUnique t tr) :
mem y (composedDeleteRoot t x tr) ↔
y ≠ x ∧ mem y tr := by
have hbag :=
composedDeleteRoot_keyBag t x ht hwf.1
have hnodup : (keyBag tr).Nodup := by
simpa only [keyBag] using
(Multiset.coe_nodup.mpr hwf.2)
have hmem :=
Multiset.Nodup.mem_erase_iff
(a := y) (b := x) hnodup
rw [← hbag] at hmem
simpa only [mem, keyBag, Multiset.mem_coe] using hmemRoot-normalized deletion preserves both structural well-formedness and global key uniqueness.
theorem composedDeleteRoot_wellFormedUnique
(t x : Nat) (ht : 2 ≤ t) {tr : BTree}
(hwf : WellFormedUnique t tr) :
WellFormedUnique t (composedDeleteRoot t x tr) := by
refine
⟨composedDeleteRoot_wellFormed t x ht hwf.1, ?_⟩
have hbag :=
composedDeleteRoot_keyBag t x ht hwf.1
have hbefore : (keyBag tr).Nodup := by
simpa only [keyBag] using
(Multiset.coe_nodup.mpr hwf.2)
have hafter :
(keyBag (composedDeleteRoot t x tr)).Nodup := by
rw [hbag]
exact hbefore.erase x
exact Multiset.coe_nodup.mp (by
simpa only [keyBag] using hafter)On well-formed trees with unique keys, executable root deletion and specification deletion have identical membership.
theorem composedDeleteRoot_mem_iff_delete
(t x y : Nat) (ht : 2 ≤ t) {tr : BTree}
(hwf : WellFormedUnique t tr) :
mem y (composedDeleteRoot t x tr) ↔
mem y (delete x tr) := by
exact
(composedDeleteRoot_mem_iff t x y ht hwf).trans
(delete_mem_iff_ne x y tr).symmOn well-formed trees with unique keys, the membership-oracle searches after executable root deletion and specification deletion agree.
theorem composedDeleteRoot_search_eq_delete
(t x y : Nat) (ht : 2 ≤ t) {tr : BTree}
(hwf : WellFormedUnique t tr) :
search y (composedDeleteRoot t x tr) =
search y (delete x tr) := by
apply Bool.eq_iff_iff.mpr
simpa only [search_true_iff] using
composedDeleteRoot_mem_iff_delete t x y ht hwfRoot-normalized deletion simultaneously has exact erase-one semantics, preserves well-formedness, and preserves or contracts height by one level.
theorem composedDeleteRoot_correct
(t x : Nat) (ht : 2 ≤ t) {tr : BTree}
(hwf : WellFormed t tr) :
keyBag (composedDeleteRoot t x tr) =
(keyBag tr).erase x ∧
WellFormed t (composedDeleteRoot t x tr) ∧
(heightOf (composedDeleteRoot t x tr) = heightOf tr ∨
heightOf (composedDeleteRoot t x tr) + 1 = heightOf tr) := by
exact
⟨composedDeleteRoot_keyBag t x ht hwf,
composedDeleteRoot_wellFormed t x ht hwf,
composedDeleteRoot_height t x ht hwf⟩end BTreeend Chapter18end CLRS