Chapter 18 — B-Trees

CLRS, fourth edition · Lean 4 formalization

The proofs below use the models and assumptions described in the scope and implementation notes.

Imports

import Mathlib

18.1. B-Tree Model

Defines the B-tree data type, key membership, and the full structural invariants (Sorted, ChildBounded, Occupancy, SameDepth). Proves that the B-TREE-SPLIT-CHILD operation preserves every invariant: splitChild_preserves_sorted, splitChild_preserves_childBounded, splitChild_preserves_occupancy, and splitChild_preserves_sameDepth, combined into splitChild_preserves_wellFormed (all with 0 sorry).

Implementation details

              namespace CLRSnamespace Chapter18inductive BTree where
  | node (keys : List Nat) (children : List BTree) : BTree
  deriving Reprnamespace BTreeopen List

Keys and membership

def keysOf : BTree -> List Nat
  | node keys children => keys ++ children.flatMap keysOf

def mem (x : Nat) (t : BTree) : Prop := x ∈ keysOf t

No represented key occurs more than once anywhere in the tree.

def UniqueKeys (tr : BTree) : Prop :=
  (keysOf tr).Nodup

              instance decidableMem (x : Nat) (t : BTree) : Decidable (mem x t) :=
  inferInstanceAs (Decidable (x ∈ keysOf t))def Valid (minDegree : Nat) (_t : BTree) : Prop := 2 <= minDegreedef search (x : Nat) (t : BTree) : Bool := decide (mem x t)theorem search_true_iff (x : Nat) (t : BTree) :
    search x t = true ↔ mem x t := by simp [search]theorem search_true_of_mem (x : Nat) (t : BTree) (hx : mem x t) :
    search x t = true := (search_true_iff x t).mpr hxtheorem mem_of_search_true (x : Nat) (t : BTree) (hx : search x t = true) :
    mem x t := (search_true_iff x t).mp hxtheorem search_false_iff (x : Nat) (t : BTree) :
    search x t = false ↔ ¬ mem x t := by simp [search]theorem search_false_of_not_mem (x : Nat) (t : BTree) (hx : ¬ mem x t) :
    search x t = false := (search_false_iff x t).mpr hxtheorem not_mem_of_search_false (x : Nat) (t : BTree) (hx : search x t = false) :
    ¬ mem x t := (search_false_iff x t).mp hxtheorem search_correct {minDegree x : Nat} {t : BTree}
    (_hvalid : Valid minDegree t) : search x t = true ↔ mem x t :=
  search_true_iff x t

Minimum-key lower bound expression

              def minKeys (minDegree height : Nat) : Nat := 2 * minDegree ^ height - 1theorem minKeys_zero (minDegree : Nat) : minKeys minDegree 0 = 1 := by simp [minKeys]
theorem minKeys_pos {minDegree height : Nat} (hdegree : 0 < minDegree) :
    0 < minKeys minDegree height := by
  unfold minKeys
  have hpow : 0 < minDegree ^ height := pow_pos hdegree height
  have hlt : 1 < 2 * minDegree ^ height := by omega
  exact Nat.sub_pos_of_lt hlttheorem one_le_minKeys {minDegree height : Nat} (hdegree : 0 < minDegree) :
    1 <= minKeys minDegree height := Nat.succ_le_of_lt (minKeys_pos hdegree)theorem minKeys_lower_bound {minDegree height : Nat} (_hdegree : 2 <= minDegree) :
    2 * minDegree ^ height - 1 <= minKeys minDegree height := by rfl
theorem minKeys_succ {minDegree height : Nat} (hdegree : 2 <= minDegree) :
    minKeys minDegree (height + 1) + 1 = minDegree * (minKeys minDegree height + 1) := by
  unfold minKeys; have hpos : 0 < minDegree := by omega
  have hpowPos : 0 < minDegree ^ height := pow_pos hpos height
  have hnextPowPos : 0 < minDegree ^ (height + 1) := pow_pos hpos (height + 1)
  have hnextTermPos : 0 < 2 * minDegree ^ (height + 1) := Nat.mul_pos (by decide) hnextPowPos
  have htermPos : 0 < 2 * minDegree ^ height := Nat.mul_pos (by decide) hpowPos
  rw [Nat.sub_add_cancel (Nat.succ_le_of_lt hnextTermPos)]
  rw [Nat.sub_add_cancel (Nat.succ_le_of_lt htermPos)]
  rw [Nat.pow_succ]; ring
theorem minKeys_le_succ {minDegree height : Nat} (hdegree : 2 <= minDegree) :
    minKeys minDegree height <= minKeys minDegree (height + 1) := by
  unfold minKeys; have hpos : 0 < minDegree := by omega
  have hpow : minDegree ^ height <= minDegree ^ (height + 1) := by
    rw [Nat.pow_succ]; exact Nat.le_mul_of_pos_right _ hpos
  exact Nat.sub_le_sub_right (Nat.mul_le_mul_left 2 hpow) 1theorem minKeys_monotone_height {minDegree h₁ h₂ : Nat}
    (hdegree : 2 <= minDegree) (hheight : h₁ <= h₂) :
    minKeys minDegree h₁ <= minKeys minDegree h₂ := by
  induction hheight with | refl => rfl | step _ ih =>
    exact Nat.le_trans ih (minKeys_le_succ hdegree)

Structural invariants

def Sorted : BTree → Prop
  | node keys children =>
    List.Pairwise (· ≤ ·) keys ∧ ∀ child ∈ children, Sorted child

def ChildBounded : BTree → Prop
  | node keys children =>
    (children.isEmpty ∨ children.length = keys.length + 1) ∧
    (∀ (i : Nat) (hi_child : i < children.length),
      let child := children.get ⟨i, hi_child⟩
      (i = 0 ∨ (match keys[i-1]? with
        | some lo => ∀ k ∈ keysOf child, lo ≤ k
        | none => True)) ∧
      (match keys[i]? with
        | some hi => ∀ k ∈ keysOf child, k ≤ hi
        | none => True)) ∧
    ∀ child ∈ children, ChildBounded child

The B-tree occupancy bounds. A non-empty root has at least one key and an internal root has at least two children; non-root nodes use the ordinary minDegree - 1 key and minDegree child lower bounds.

def Occupancy (minDegree : Nat) (isRoot : Bool) : BTree → Prop
  | node keys children =>
    let lower := if isRoot then
      (if keys.length = 0 ∧ children.isEmpty then 0 else 1) else minDegree - 1
    let upper := 2 * minDegree - 1
    let childLower := if isRoot then 2 else minDegree
    lower ≤ keys.length ∧ keys.length ≤ upper ∧
    (children.isEmpty ∨
      (childLower ≤ children.length ∧ children.length ≤ 2 * minDegree)) ∧
    ∀ child ∈ children, Occupancy minDegree false child

              def heightOf : BTree → Nat
  | node _ [] => 0
  | node _ cs => 1 + ((cs.map heightOf).foldl max 0)inductive SameDepth : BTree → Prop
  | leaf (ks : List Nat) : SameDepth (node ks [])
  | internal (ks : List Nat) (c0 : BTree) (cs : List BTree) :
      (∀ c ∈ cs, heightOf c = heightOf c0) → SameDepth c0 → (∀ c ∈ cs, SameDepth c) →
      SameDepth (node ks (c0 :: cs))def WellFormed (minDegree : Nat) (t : BTree) : Prop :=
  Sorted t ∧ ChildBounded t ∧ Occupancy minDegree true t ∧ SameDepth t

Structural B-tree well-formedness plus global key uniqueness.

def WellFormedUnique (t : Nat) (tr : BTree) : Prop :=
  WellFormed t tr ∧ UniqueKeys tr

theorem WellFormed.valid {minDegree : Nat} {t : BTree}
    (hmin : 2 ≤ minDegree) (_h : WellFormed minDegree t) : Valid minDegree t := by
  unfold Valid; exact hmin

theorem wellFormed_empty (minDegree : Nat) (Variable name `hmin` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hmin : 2 ≤ minDegree) :
    WellFormed minDegree (node [] []) := by
  unfold WellFormed Sorted ChildBounded Occupancy
  refine ⟨?_, ?_, ?_, SameDepth.leaf []⟩
  · unfold Sorted; simp
  · unfold ChildBounded; simp
  · unfold Occupancy; simp

B-TREE-SPLIT-CHILD operation

def splitChild (t : Nat) : BTree → Nat → BTree
  | node keys children, i =>
    if h : i < children.length then
      match children.get ⟨i, h⟩ with
      | node cKeys cChildren =>
        if cKeys.length = 2 * t - 1 then
          match cKeys.splitAt (t - 1), cChildren.splitAt t with
          | (leftKeys, medianKey :: rightKeys), (leftCh, rightCh) =>
            BTree.node (keys.take i ++ medianKey :: keys.drop i)
              (children.take i ++ [BTree.node leftKeys leftCh, BTree.node rightKeys rightCh] ++
                children.drop (i + 1))
          | _, _ => node keys children
        else
          node keys children
    else
      node keys children

Occupancy preservation under splitChild

              lemma splitAt_first_half_length (cKeys : List Nat) (t : Nat) (hfull : cKeys.length = 2 * t - 1) :
    (cKeys.splitAt (t - 1)).1.length = t - 1 := by
  simp [hfull]; omega

lemma splitAt_second_half_length (cKeys : List Nat) (t : Nat)
    (hfull : cKeys.length = 2 * t - 1) (ht : 1 ≤ t) :
    ((cKeys.splitAt (t - 1)).2.drop 1).length = t - 1 := by
  have h_snd_len : (cKeys.splitAt (t - 1)).2.length = t := by
    simp [hfull]; omega
  simp [This simp argument is unused:
  h_snd_len

Hint: Omit it from the simp argument list.
  simp ̵[̵h̵_̵s̵n̵d̵_̵l̵e̵n̵]̵

Note: This linter can be disabled with `set_option linter.unusedSimpArgs false`h_snd_len]; omega

theorem splitChild_new_children_key_counts (t : Nat) (ht : 2 ≤ t)
    (cKeys : List Nat) (hfull : cKeys.length = 2 * t - 1) :
    ((cKeys.splitAt (t - 1)).1).length = t - 1 ∧
    ((cKeys.splitAt (t - 1)).2.drop 1).length = t - 1 := by
  have ht_pos : 1 ≤ t := by omega
  exact ⟨splitAt_first_half_length cKeys t hfull,
          splitAt_second_half_length cKeys t hfull ht_pos⟩theorem splitChild_parent_key_bound (t : Nat) (Variable name `ht` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`ht : 2 ≤ t) (keys : List Nat)
    (hparent_nonfull : keys.length < 2 * t - 1) :
    keys.length + 1 ≤ 2 * t - 1 := by
  omega

List utility: foldl max over uniform values



lemma foldl_max_idem (l : List Nat) (a : Nat) (h : ∀ b ∈ l, b = a) : foldl max a l = a := by
  induction l with
  | nil => simp
  | cons x xs ih =>
    have hx : x = a := h x (by simp)
    have hxs : ∀ b ∈ xs, b = a := by
      intro b hb; exact h b (by simp [hb])
    rw [hx]
    simp [ih hxs]



lemma foldl_max_eq_of_all_eq (l : List Nat) (v : Nat) (h_ne : l ≠ [])
    (h : ∀ a ∈ l, a = v) : l.foldl max 0 = v := by
  cases l with
  | nil => contradiction
  | cons x xs =>
    have hx : x = v := h x (by simp)
    have hxs : ∀ a ∈ xs, a = v := by
      intro a ha; exact h a (by simp [ha])
    rw [hx]
    simp
    exact foldl_max_idem xs v hxs

SameDepth infrastructure and preservation

              Try this: intro ks' c0' cs' h_heights _h_sd_c0' _h_sd_children' c₁ hc₁ c₂ hc₂Try this: intro ks' c0' cs' h_heights _h_sd_c0' _h_sd_children' c₁ hc₁ c₂ hc₂Try this: intro ks' c0' cs' h_heights _h_sd_c0' _h_sd_children' c₁ hc₁ c₂ hc₂Try this: intro ks' c₁ hc₁Try this: intro ks' c₁ hc₁Try this: intro ks' c₁ hc₁

lemma sameDepth_children_eq_height {ks : List Nat} {c0 : BTree} {cs : List BTree}
    (hsd : SameDepth (node ks (c0 :: cs))) :
    ∀ c₁ ∈ (c0 :: cs), ∀ c₂ ∈ (c0 :: cs), heightOf c₁ = heightOf c₂ := by
  refine SameDepth.casesOn hsd
    (motive := λ t _ => match t with
      | node _ children => ∀ c₁ ∈ children, ∀ c₂ ∈ children, heightOf c₁ = heightOf c₂)
    ?leaf ?internal
  · Try this: intro ks' c₁ hc₁intro ks'; intro c₁ hc₁; simp at hc₁
  · Try this: intro ks' c0' cs' h_heights _h_sd_c0' _h_sd_children' c₁ hc₁ c₂ hc₂intro ks' c0' cs' h_heights _h_sd_c0' _h_sd_children'
    intro c₁ hc₁ c₂ hc₂
    simp at hc₁ hc₂
    rcases hc₁ with (rfl | hc₁')
    · rcases hc₂ with (rfl | hc₂')
      · rfl
      · symm; exact h_heights c₂ hc₂'
    · rcases hc₂ with (rfl | hc₂')
      · exact h_heights c₁ hc₁'
      · rw [h_heights c₁ hc₁', h_heights c₂ hc₂']lemma sameDepth_head_sd {ks : List Nat} {c0 : BTree} {cs : List BTree}
    (hsd : SameDepth (node ks (c0 :: cs))) : SameDepth c0 := by
  refine SameDepth.casesOn hsd (motive := λ t _ => match t with
    | node _ (c0' :: _) => SameDepth c0'
    | node _ [] => True) ?leaf ?internal
  · intro ks'; trivial
  · intro ks' c0' cs' _ h_sd_c0' _; exact h_sd_c0'lemma sameDepth_tail_sd {ks : List Nat} {c0 : BTree} {cs : List BTree}
    (hsd : SameDepth (node ks (c0 :: cs))) (c : BTree) (hc : c ∈ cs) : SameDepth c := by
  refine SameDepth.casesOn hsd (motive := λ t _ => match t with
    | node _ (c0' :: cs') => ∀ c' ∈ cs', SameDepth c'
    | node _ [] => ∀ c' ∈ [], SameDepth c') ?leaf ?internal c hc
  · intro ks' c' hc'; simp at hc'
  · intro ks' c0' cs' _ _ h_sd_children'; exact h_sd_children'

lemma sameDepth_take (cKeys : List Nat) (cChildren : List BTree) (t : Nat)
    (hsd : SameDepth (node cKeys cChildren)) (ht_pos : 1 ≤ t) :
    SameDepth (node ((cKeys.splitAt (t - 1)).1) ((cChildren.splitAt t).1)) := by
  cases cChildren with
  | nil => simp; exact SameDepth.leaf _
  | cons d0 ds =>
    have h_take : ((d0 :: ds).splitAt t).1 = d0 :: (ds.take (t-1)) := by
      cases t; omega; rename_i n; simp
    rw [h_take]
    have h_sd_d0 : SameDepth d0 := sameDepth_head_sd hsd
    have h_sd_ds : ∀ d ∈ ds.take (t-1), SameDepth d := by
      intro d hd
      exact sameDepth_tail_sd hsd d ((take_sublist (t-1) ds).subset hd)
    have h_heights : ∀ d ∈ ds.take (t-1), heightOf d = heightOf d0 := by
      intro d hd
      have hmem : d ∈ d0 :: ds := by
        apply mem_cons_of_mem d0
        exact (take_sublist (t-1) ds).subset hd
      exact (sameDepth_children_eq_height hsd) d hmem d0 (by simp)
    exact SameDepth.internal ((cKeys.splitAt (t - 1)).1) d0 (ds.take (t-1))
      h_heights h_sd_d0 h_sd_ds

lemma sameDepth_drop (cKeys : List Nat) (cChildren : List BTree) (t : Nat)
    (hsd : SameDepth (node cKeys cChildren)) (ht_pos : 1 ≤ t) :
    SameDepth (node ((cKeys.splitAt (t - 1)).2.drop 1) ((cChildren.splitAt t).2)) := by
  cases cChildren with
  | nil => simp; exact SameDepth.leaf _
  | cons d0 ds =>
    have h_drop : ((d0 :: ds).splitAt t).2 = ds.drop (t-1) := by
      cases t; omega; rename_i n; simp
    rw [h_drop]
    by_cases h_empty : ds.drop (t-1) = []
    · simp [h_empty]; exact SameDepth.leaf _
    · match h_drop_suffix : ds.drop (t-1) with
      | [] => exact (h_empty h_drop_suffix).elim
      | e0 :: es =>
        have he0_mem_drop : e0 ∈ ds.drop (t-1) := by rw [h_drop_suffix]; simp
        have he0_ds : e0 ∈ ds := (drop_sublist (t-1) ds).subset he0_mem_drop
        have h_sd_e0 : SameDepth e0 := sameDepth_tail_sd hsd e0 he0_ds
        have h_sd_es : ∀ e ∈ es, SameDepth e := by
          intro e he
          have he_mem_drop : e ∈ ds.drop (t-1) := by rw [h_drop_suffix]; simp [he]
          have he_ds : e ∈ ds := (drop_sublist (t-1) ds).subset he_mem_drop
          exact sameDepth_tail_sd hsd e he_ds
        have h_heights : ∀ e ∈ es, heightOf e = heightOf e0 := by
          intro e he
          have he_mem_drop : e ∈ ds.drop (t-1) := by rw [h_drop_suffix]; simp [he]
          have he_ds : e ∈ ds := (drop_sublist (t-1) ds).subset he_mem_drop
          have he0_cons : e0 ∈ d0 :: ds := by simp [he0_ds]
          have he_cons : e ∈ d0 :: ds := by simp [he_ds]
          exact (sameDepth_children_eq_height hsd) e he_cons e0 he0_cons
        refine SameDepth.internal ((cKeys.splitAt (t - 1)).2.drop 1) e0 es
          h_heights h_sd_e0 h_sd_es

Height of a SameDepth internal node

              

lemma heightOf_uniform_children {ks : List Nat} {c0 : BTree} {cs : List BTree}
    (h : ∀ c ∈ cs, heightOf c = heightOf c0) :
    heightOf (node ks (c0 :: cs)) = 1 + heightOf c0 := by
  simp [heightOf]
  refine (Nat.succ_inj).mp ?_
  simp
  refine foldl_max_idem (List.map heightOf cs) (heightOf c0) ?_
  intro x hx
  rw [List.mem_map] at hx
  rcases hx with ⟨c, hc, rfl⟩
  exact h c hclemma heightOf_internal_of_sameDepth {ks : List Nat} {c0 : BTree} {cs : List BTree}
    (hsd : SameDepth (node ks (c0 :: cs))) : heightOf (node ks (c0 :: cs)) = 1 + heightOf c0 := by
  match hsd with
  | SameDepth.internal ks' c0' cs' h_heights _ _ =>
    exact heightOf_uniform_children h_heightstry 'simp' instead of 'simpa'

Note: This linter can be disabled with `set_option linter.unnecessarySimpa false`

lemma heightOf_split_parts_eq (cKeys : List Nat) (cChildren : List BTree) (t : Nat)
    (hsd : SameDepth (node cKeys cChildren))
    (ht_pos : 0 < t)
    (h_children : cChildren = [] ∨ t < cChildren.length) :
    heightOf (node ((cKeys.splitAt (t - 1)).1) ((cChildren.splitAt t).1)) =
    heightOf (node cKeys cChildren) ∧
    heightOf (node ((cKeys.splitAt (t - 1)).2.drop 1) ((cChildren.splitAt t).2)) =
    heightOf (node cKeys cChildren) := by
  rcases h_children with (h_empty | h_gt)
  · subst h_empty; simp [heightOf]
  · have h_nonempty : cChildren ≠ [] := by
      intro h; rw [h] at h_gt; simp at h_gt
    cases h_cases : cChildren with
    | nil => exact (h_nonempty h_cases).elim
    | cons d0 ds =>
      have hsd_internal : heightOf (node cKeys (d0 :: ds)) = 1 + heightOf d0 :=
        heightOf_internal_of_sameDepth (by rwa [h_cases] at hsd)
      have h_all_eq : ∀ c₁ ∈ (d0 :: ds), ∀ c₂ ∈ (d0 :: ds), heightOf c₁ = heightOf c₂ :=
        sameDepth_children_eq_height (by rwa [h_cases] at hsd)
      have h_take_head : ((d0 :: ds).splitAt t).1 = d0 :: (ds.take (t - 1)) := by
        cases t; omega; rename_i n; simp
      rw [h_take_head]
      have h_left_heights : ∀ c ∈ ds.take (t - 1), heightOf c = heightOf d0 := by
        intro c hc
        have hc_mem : c ∈ d0 :: ds :=
          List.mem_cons_of_mem _ ((List.take_sublist (t - 1) ds).subset hc)
        exact h_all_eq c hc_mem d0 (by simp)
      have h_left_height : heightOf (node ((cKeys.splitAt (t - 1)).1) (d0 :: ds.take (t - 1))) =
          1 + heightOf d0 :=
        heightOf_uniform_children h_left_heights
      have h_drop_eq : ((d0 :: ds).splitAt t).2 = ds.drop (t - 1) := by
        cases t; omega; rename_i n; simp
      rw [h_drop_eq]
      have h_right_nonempty : ds.drop (t - 1) ≠ [] := by
        have hlen_cons : t < (d0 :: ds).length := by simpa [h_cases] using h_gt
        intro h
        have hlen0 : (ds.drop (t - 1)).length = 0 := by try 'simp' instead of 'simpa'

Note: This linter can be disabled with `set_option linter.unnecessarySimpa false`simpa [h]
        rw [List.length_drop] at hlen0
        have : ds.length ≤ t - 1 := by omega
        have : ds.length + 1 ≤ t := by omega
        simp at hlen_cons
        omega
      match h_drop_suffix : ds.drop (t - 1) with
      | nil => exact (h_right_nonempty h_drop_suffix).elim
      | cons e0 es =>
        have h_right_heights : ∀ c ∈ es, heightOf c = heightOf e0 := by
          intro c hc
          have hc_mem : c ∈ d0 :: ds := by
            apply List.mem_cons_of_mem _
            have hmem_drop : c ∈ ds.drop (t - 1) := by rw [h_drop_suffix]; simp [hc]
            exact (List.drop_sublist (t - 1) ds).subset hmem_drop
          have he0_mem : e0 ∈ d0 :: ds := by
            apply List.mem_cons_of_mem _
            have he0_drop : e0 ∈ ds.drop (t - 1) := by rw [h_drop_suffix]; simp
            exact (List.drop_sublist (t - 1) ds).subset he0_drop
          exact h_all_eq c hc_mem e0 he0_mem
        have h_right_height : heightOf (node ((cKeys.splitAt (t - 1)).2.drop 1) (e0 :: es)) =
            1 + heightOf e0 :=
          heightOf_uniform_children h_right_heights
        have h_d0_e0_height : heightOf e0 = heightOf d0 := by
          have he0_mem : e0 ∈ d0 :: ds := by
            apply List.mem_cons_of_mem _
            have he0_drop : e0 ∈ ds.drop (t - 1) := by rw [h_drop_suffix]; simp
            exact (List.drop_sublist (t - 1) ds).subset he0_drop
          exact h_all_eq e0 he0_mem d0 (by simp)
        rw [h_d0_e0_height] at h_right_height
        rw [h_left_height, h_right_height, hsd_internal]
        exact ⟨rfl, rfl⟩

theorem splitChild_preserves_sameDepth (t : Nat) (ht : 2 ≤ t)
    (keys : List Nat) (children : List BTree)
    (cKeys : List Nat) (cChildren : List BTree) (i : Nat)
    (h_lt : i < children.length)
    (hchild_eq : children.get ⟨i, h_lt⟩ = node cKeys cChildren)
    (hchild_full : cKeys.length = 2 * t - 1)
    (hchild_children : cChildren = [] ∨ t < cChildren.length)
    (hsd : SameDepth (node keys children)) :
    SameDepth (splitChild t (node keys children) i) := by
  have ht_pos : 1 ≤ t := by omega
  have ht_pos' : 0 < t := by omega
  have h_keys_snd_nonempty : (cKeys.splitAt (t - 1)).2 ≠ [] := by
    have hlen : (cKeys.splitAt (t - 1)).2.length = t := by simp [hchild_full]; omega
    intro h; rw [h] at hlen; simp at hlen; omega
  dsimp [splitChild]
  rw [dif_pos h_lt]
  have h_get : children[i] = node cKeys cChildren := by simpa using hchild_eq
  rw [h_get]
  dsimp
  rw [if_pos hchild_full]
  cases hk : cKeys.splitAt (t - 1) with
  | mk leftKeys keysRest =>
    have h_keysRest_nonempty : keysRest ≠ [] := by
      have : (cKeys.splitAt (t - 1)).2 = keysRest := by rw [hk]
      rw [← this]; exact h_keys_snd_nonempty
    cases hkr : keysRest with
    | nil => exact (h_keysRest_nonempty hkr).elim
    | cons medianKey rightKeys =>
      cases hc : cChildren.splitAt t with
      | mk leftCh rightCh =>
        -- The match reduces to the success branch
        show SameDepth (BTree.node (take i keys ++ medianKey :: drop i keys)
          (take i children ++ [BTree.node leftKeys leftCh, BTree.node rightKeys rightCh] ++
            drop (i + 1) children))
        cases hsd with
        | leaf ks => simp at h_lt
        | internal ks c0 cs h_heights h_sd_c0 h_sd_cs =>
          have h_sd_child : SameDepth (node cKeys cChildren) := by
            rcases Nat.eq_zero_or_pos i with (rfl | hi_pos')
            · have hc0_eq : c0 = node cKeys cChildren := by simpa using hchild_eq
              rw [← hc0_eq]; exact h_sd_c0
            · have h_get' : (c0 :: cs).get ⟨i, h_lt⟩ = cs.get ⟨i - 1, by
                simp at h_lt; omega⟩ := by
                rcases i with (rfl | i)
                · exact (Nat.not_lt_zero _ hi_pos').elim
                · simp
              have hmem : cs.get ⟨i - 1, by simp at h_lt; omega⟩ ∈ cs := by
                apply List.get_mem
              rw [← hchild_eq, h_get']
              exact h_sd_cs _ hmem
          have h_keys_left : ((cKeys.splitAt (t - 1)).1) = leftKeys := by rw [hk]
          have h_keys_right : ((cKeys.splitAt (t - 1)).2.drop 1) = rightKeys := by
            rw [hk]; simp [hkr]
          have h_ch_left : ((cChildren.splitAt t).1) = leftCh := by rw [hc]
          have h_ch_right : ((cChildren.splitAt t).2) = rightCh := by rw [hc]
          have h_sd_left : SameDepth (node leftKeys leftCh) := by
            rw [← h_keys_left, ← h_ch_left]; exact sameDepth_take cKeys cChildren t h_sd_child ht_pos
          have h_sd_right : SameDepth (node rightKeys rightCh) := by
            rw [← h_keys_right, ← h_ch_right]; exact sameDepth_drop cKeys cChildren t h_sd_child ht_pos
          have h_heights_split := heightOf_split_parts_eq cKeys cChildren t h_sd_child ht_pos' hchild_children
          have h_height_left : heightOf (node leftKeys leftCh) = heightOf (node cKeys cChildren) := by
            rw [← h_keys_left, ← h_ch_left]; exact h_heights_split.1
          have h_height_right : heightOf (node rightKeys rightCh) = heightOf (node cKeys cChildren) := by
            rw [← h_keys_right, ← h_ch_right]; exact h_heights_split.2
          have h_child_eq_c0_height : heightOf (node cKeys cChildren) = heightOf c0 := by
            rcases Nat.eq_zero_or_pos i with (rfl | hi_pos')
            · have hc0_eq : c0 = node cKeys cChildren := by simpa using hchild_eq
              rw [← hc0_eq]
            · have h_get' : (c0 :: cs).get ⟨i, h_lt⟩ = cs.get ⟨i - 1, by
                simp at h_lt; omega⟩ := by
                rcases i with (rfl | i)
                · exact (Nat.not_lt_zero _ hi_pos').elim
                · simp
              have hmem : cs.get ⟨i - 1, by simp at h_lt; omega⟩ ∈ cs := by
                apply List.get_mem
              rw [← hchild_eq, h_get']
              exact h_heights _ hmem
          rcases Nat.eq_zero_or_pos i with (rfl | hi_pos)
          · -- i = 0: result children = newLeft :: newRight :: cs
            have h_rest_heights : ∀ c ∈ (node rightKeys rightCh :: cs),
                heightOf c = heightOf (node leftKeys leftCh) := by
              intro c hc; simp at hc; rcases hc with (rfl | hc_cs)
              · rw [h_height_right, h_height_left]
              · rw [h_heights c hc_cs, ← h_child_eq_c0_height, h_height_left]
            have h_rest_sd : ∀ c ∈ (node rightKeys rightCh :: cs), SameDepth c := by
              intro c hc; simp at hc; rcases hc with (rfl | hc_cs)
              · exact h_sd_right
              · exact h_sd_cs c hc_cs
            refine SameDepth.internal (take 0 keys ++ medianKey :: drop 0 keys)
              (node leftKeys leftCh) (node rightKeys rightCh :: cs) h_rest_heights h_sd_left h_rest_sd
          · -- i > 0: result children = c0 :: take(i-1)cs ++ left :: right :: drop i cs
            have h_take : take i (c0 :: cs) = c0 :: take (i - 1) cs := by
              rcases i with (rfl | i)
              · exact (Nat.not_lt_zero _ hi_pos).elim
              · simp
            have h_drop_succ : drop (i + 1) (c0 :: cs) = drop i cs := by simp
            rw [h_take, h_drop_succ]
            simp only [List.cons_append, List.append_assoc, List.nil_append]
            have h_rest_heights : ∀ c ∈ (take (i - 1) cs ++ (node leftKeys leftCh :: node rightKeys rightCh :: drop i cs)),
                heightOf c = heightOf c0 := by
              intro c hc
              rw [List.mem_append] at hc
              rcases hc with (hc | hc)
              · have hmem : c ∈ cs := (List.take_sublist _ _).subset hc
                exact h_heights c hmem
              · simp at hc; rcases hc with (rfl | rfl | hc)
                · rw [h_height_left, h_child_eq_c0_height]
                · rw [h_height_right, h_child_eq_c0_height]
                · have hmem : c ∈ cs := (List.drop_sublist _ _).subset hc
                  exact h_heights c hmem
            have h_rest_sd : ∀ c ∈ (take (i - 1) cs ++ (node leftKeys leftCh :: node rightKeys rightCh :: drop i cs)),
                SameDepth c := by
              intro c hc
              rw [List.mem_append] at hc
              rcases hc with (hc | hc)
              · have hmem : c ∈ cs := (List.take_sublist _ _).subset hc
                exact h_sd_cs c hmem
              · simp at hc; rcases hc with (rfl | rfl | hc)
                · exact h_sd_left
                · exact h_sd_right
                · have hmem : c ∈ cs := (List.drop_sublist _ _).subset hc
                  exact h_sd_cs c hmem
            refine SameDepth.internal (take i keys ++ medianKey :: drop i keys) c0
              (take (i - 1) cs ++ (node leftKeys leftCh :: node rightKeys rightCh :: drop i cs))
              h_rest_heights h_sd_c0 h_rest_sd

splitChild occupancy preservation (stub)

The following theorem states that splitChild preserves the Occupancy invariant. The proof requires:

Arithmetic showing that the two new children have t-1 keys each (from splitAt_first_half_length / splitAt_second_half_length)
Arithmetic showing that children counts stay within [t, 2t] (requires ChildBounded to know cChildren.length = 2t when non-empty)
Propagation of sub-node occupancy from the original child.

              -- Helper: extract child occupancy from parent occupancy
lemma occupancy_of_child {minDegree : Nat} {isRoot : Bool} {keys : List Nat} {children : List BTree}
    (h_occ : Occupancy minDegree isRoot (node keys children))
    (i : Nat) (hi : i < children.length) :
    Occupancy minDegree false (children.get ⟨i, hi⟩) := by
  unfold Occupancy at h_occ
  rcases h_occ with ⟨_, _, _, h_sub⟩
  apply h_sub
  apply List.get_mem

-- Helper: from ChildBounded of a full node, children length is 0 or 2t
lemma child_children_len_of_full_cb {t : Nat} (ht : 2 ≤ t) {cKeys : List Nat} {cChildren : List BTree}
    (h_cb : ChildBounded (node cKeys cChildren)) (h_full : cKeys.length = 2 * t - 1) :
    cChildren.length = 0 ∨ cChildren.length = 2 * t := by
  unfold ChildBounded at h_cb
  rcases h_cb with ⟨h_rel, _, _⟩
  rcases h_rel with (h_empty | h_eq)
  · left; cases cChildren with | nil => rfl | cons x xs => simp at h_empty
  · right; rw [h_eq, h_full]; omega

theorem splitChild_preserves_occupancy (t : Nat) (ht : 2 ≤ t)
    (keys : List Nat) (children : List BTree)
    (cKeys : List Nat) (cChildren : List BTree) (i : Nat)
    (h_lt : i < children.length)
    (hchild_eq : children.get ⟨i, h_lt⟩ = node cKeys cChildren)
    (hchild_full : cKeys.length = 2 * t - 1)
    (hparent_nonfull : keys.length < 2 * t - 1)
    (h_occ : Occupancy t true (node keys children))
    (h_cb : ChildBounded (node keys children)) :
    Occupancy t true (splitChild t (node keys children) i) := by
  have ht_pos : 0 < t := by omega
  have ht_pos' : 1 ≤ t := by omega
  -- Extract child invariants
  have hchild_occ : Occupancy t false (node cKeys cChildren) := by
    rw [← hchild_eq]; exact occupancy_of_child h_occ i h_lt
  have hchild_cb : ChildBounded (node cKeys cChildren) := by
    rw [← hchild_eq]; unfold ChildBounded at h_cb
    rcases h_cb with ⟨_, _, h_sub⟩; apply h_sub; apply List.get_mem
  have h_cChildren_len := child_children_len_of_full_cb ht hchild_cb hchild_full
  -- Unfold splitChild (same pattern as splitChild_preserves_sameDepth)
  have h_keys_snd_nonempty : (cKeys.splitAt (t - 1)).2 ≠ [] := by
    have hlen : (cKeys.splitAt (t - 1)).2.length = t := by simp [hchild_full]; omega
    intro h; rw [h] at hlen; simp at hlen; omega
  dsimp [splitChild]; rw [dif_pos h_lt]
  have h_get : children[i] = node cKeys cChildren := by simpa using hchild_eq
  rw [h_get]; dsimp; rw [if_pos hchild_full]
  cases hk : cKeys.splitAt (t - 1) with
  | mk leftKeys keysRest =>
    have h_keysRest_nonempty : keysRest ≠ [] := by
      have : (cKeys.splitAt (t - 1)).2 = keysRest := by rw [hk]
      rw [← this]; exact h_keys_snd_nonempty
    cases hkr : keysRest with
    | nil => exact (h_keysRest_nonempty hkr).elim
    | cons medianKey rightKeys =>
      cases hc : cChildren.splitAt t with
      | mk leftCh rightCh =>
        show Occupancy t true (BTree.node (take i keys ++ medianKey :: drop i keys)
          (take i children ++ [BTree.node leftKeys leftCh, BTree.node rightKeys rightCh] ++
            drop (i + 1) children))
        -- Relate local names to splitAt results (matching SameDepth proof pattern)
        have h_keys_left : ((cKeys.splitAt (t - 1)).1) = leftKeys := by rw [hk]
        have h_keys_right : ((cKeys.splitAt (t - 1)).2.drop 1) = rightKeys := by
          rw [hk]; simp [hkr]
        have h_ch_left : ((cChildren.splitAt t).1) = leftCh := by rw [hc]
        have h_ch_right : ((cChildren.splitAt t).2) = rightCh := by rw [hc]
        -- Key length facts (using ← to apply splitAt lemmas)
        have h_leftKeys_len : leftKeys.length = t - 1 := by
          rw [← h_keys_left]; exact splitAt_first_half_length cKeys t hchild_full
        have h_rightKeys_len : rightKeys.length = t - 1 := by
          rw [← h_keys_right]; exact splitAt_second_half_length cKeys t hchild_full ht_pos'
        -- Children count bounds for the two new children
        have h_leftCh_bound : leftCh.isEmpty ∨ (t ≤ leftCh.length ∧ leftCh.length ≤ 2 * t) := by
          rcases h_cChildren_len with (h0 | h2t)
          · -- cChildren.length = 0 → cChildren = [] → leftCh = []
            have hnil : cChildren = [] := by
              cases cChildren with | nil => rfl | cons x xs => simp at h0
            left; rw [← h_ch_left, hnil]; simp
          · -- cChildren.length = 2t → leftCh.length = t
            right; rw [← h_ch_left]; simp [h2t]; omega
        have h_rightCh_bound : rightCh.isEmpty ∨ (t ≤ rightCh.length ∧ rightCh.length ≤ 2 * t) := by
          rcases h_cChildren_len with (h0 | h2t)
          · have hnil : cChildren = [] := by
              cases cChildren with | nil => rfl | cons x xs => simp at h0
            left; rw [← h_ch_right, hnil]; simp
          · right; rw [← h_ch_right]; simp [h2t]; omega
        -- Occupancy for the two new children (non-root)
        have h_occ_left : Occupancy t false (BTree.node leftKeys leftCh) := by
          unfold Occupancy
          refine ⟨?_, ?_, h_leftCh_bound, ?_⟩
          · rw [h_leftKeys_len]; exact le_rfl
          · rw [h_leftKeys_len]; omega
          · intro child hchild
            rw [← h_ch_left] at hchild; simp at hchild
            have : child ∈ cChildren :=
              (take_sublist t cChildren).subset hchild
            unfold Occupancy at hchild_occ
            rcases hchild_occ with ⟨_, _, _, h_occ_sub⟩
            exact h_occ_sub child this
        have h_occ_right : Occupancy t false (BTree.node rightKeys rightCh) := by
          unfold Occupancy
          refine ⟨?_, ?_, h_rightCh_bound, ?_⟩
          · rw [h_rightKeys_len]; exact le_rfl
          · rw [h_rightKeys_len]; omega
          · intro child hchild
            rw [← h_ch_right] at hchild; simp at hchild
            have : child ∈ cChildren :=
              (drop_sublist t cChildren).subset hchild
            unfold Occupancy at hchild_occ
            rcases hchild_occ with ⟨_, _, _, h_occ_sub⟩
            exact h_occ_sub child this
        -- Parent occupancy after split: prove the four conjuncts
        -- Derive i ≤ keys.length from ChildBounded and h_lt
        have h_i_le_keys : i ≤ keys.length := by
          unfold ChildBounded at h_cb; rcases h_cb with ⟨h_cb_rel, _, _⟩
          rcases h_cb_rel with (h_cb_empty | h_cb_eq)
          · have h_len0 : children.length = 0 := by simpa using h_cb_empty
            have : i < 0 := by rwa [h_len0] at h_lt
            omega
          · rw [h_cb_eq] at h_lt; omega
        unfold Occupancy
        have h_newKeys_len : (take i keys ++ medianKey :: drop i keys).length = keys.length + 1 := by
          simp [h_i_le_keys]; omega
        have h_newChildren_len : (take i children ++
            [BTree.node leftKeys leftCh, BTree.node rightKeys rightCh] ++
            drop (i + 1) children).length = children.length + 1 := by
          simp; omega
        refine ⟨?_, ?_, ?_, ?_⟩
        · -- lower bound: the newKeys list is non-empty (contains medianKey)
          have h_ne_nil : take i keys ++ medianKey :: drop i keys ≠ [] := by simp
          have h_pos : 0 < (take i keys ++ medianKey :: drop i keys).length := by omega
          have h_one_le : 1 ≤ (take i keys ++ medianKey :: drop i keys).length := by omega
          have h_if_val : (if (take i keys ++ medianKey :: drop i keys).length = 0 ∧
              (take i children ++ [BTree.node leftKeys leftCh, BTree.node rightKeys rightCh] ++
                drop (i+1) children).isEmpty then 0 else 1) = 1 := by
            by_cases hzero : (take i keys ++ medianKey :: drop i keys).length = 0
            · exfalso; exact h_pos.ne' hzero
            · simp [This simp argument is unused:
  hzero

Hint: Omit it from the simp argument list.
  simp ̵[̵h̵z̵e̵r̵o̵]̵

Note: This linter can be disabled with `set_option linter.unusedSimpArgs false`hzero]
          rw [h_if_val]; exact h_one_le
        · -- newKeys.length ≤ 2t-1 (parent was not full, added 1 key)
          rw [h_newKeys_len]; omega
        · -- children count: newChildren non-empty, length = children.length + 1
          rw [h_newChildren_len]; right
          have h_low : 2 ≤ children.length + 1 := by
            omega
          have h_high : children.length + 1 ≤ 2 * t := by
            unfold ChildBounded at h_cb; rcases h_cb with ⟨h_cb_rel, _, _⟩
            rcases h_cb_rel with (h_cb_empty | h_cb_eq)
            · have h_len0 : children.length = 0 := by simpa using h_cb_empty
              rw [h_len0]; omega
            · rw [h_cb_eq]
              have h_add := Nat.add_lt_add_right hparent_nonfull 1
              rw [Nat.sub_add_cancel (show 1 ≤ 2 * t from by omega)] at h_add
              rw [← Nat.succ_eq_add_one (keys.length + 1)]
              exact Nat.succ_le_of_lt h_add
          exact ⟨h_low, h_high⟩
        · -- sub-node occupancy propagation
          -- newChildren = (take i children) ++ [newLeft, newRight] ++ (drop (i+1) children)
          -- Due to ++ associativity: (take ++ [a,b]) ++ drop
          intro child hchild
          have h_or := List.mem_append.mp hchild
          rcases h_or with (h_take_or_new | h_drop)
          · -- child ∈ take i children ++ [newLeft, newRight]
            have h_or2 := List.mem_append.mp h_take_or_new
            rcases h_or2 with (h_take | h_new)
            · -- child ∈ take i children → inherits from parent occupancy
              have hmem : child ∈ children := (take_sublist i children).subset h_take
              unfold Occupancy at h_occ; rcases h_occ with ⟨_, _, _, h_pocc_sub⟩
              exact h_pocc_sub child hmem
            · -- child ∈ [newLeft, newRight]
              simp at h_new; rcases h_new with (rfl | rfl)
              · exact h_occ_left
              · exact h_occ_right
          · -- child ∈ drop (i+1) children → inherits from parent occupancy
            have hmem : child ∈ children := (drop_sublist (i+1) children).subset h_drop
            unfold Occupancy at h_occ; rcases h_occ with ⟨_, _, _, h_pocc_sub⟩
            exact h_pocc_sub child hmem

lemma pairwise_get_mono {l : List Nat} (hp : List.Pairwise (· ≤ ·) l) {j k : Nat}
    (hjk : j ≤ k) (hj : j < l.length) (hk : k < l.length) : l.get ⟨j, hj⟩ ≤ l.get ⟨k, hk⟩ := by
  induction' hp with a l' h_all hp_tail ih generalizing j k
  · exfalso; exact Nat.not_lt_zero j hj
  · rcases k with (rfl | k)
    · have hj0 : j = 0 := Nat.eq_zero_of_le_zero hjk
      subst hj0; exact Nat.le_refl _
    · have hk_lt : k < l'.length := by
        have : k+1 < (a :: l').length := hk; simpa using this
      rcases j with (rfl | j)
      · simp; apply h_all; apply List.get_mem
      · have hj_lt : j < l'.length := by
          have : j+1 < (a :: l').length := hj; simpa using this
        simp; apply ih (by omega) hj_lt hk_lt

theorem splitChild_preserves_sorted (t : Nat) (ht : 2 ≤ t)
    (keys : List Nat) (children : List BTree)
    (cKeys : List Nat) (cChildren : List BTree) (i : Nat)
    (h_lt : i < children.length)
    (hchild_eq : children.get ⟨i, h_lt⟩ = node cKeys cChildren)
    (hchild_full : cKeys.length = 2 * t - 1)
    (h_sorted : Sorted (node keys children))
    (h_cb : ChildBounded (node keys children)) :
    Sorted (splitChild t (node keys children) i) := by
  have h_keys_snd_nonempty : (cKeys.splitAt (t - 1)).2 ≠ [] := by
    have hlen : (cKeys.splitAt (t - 1)).2.length = t := by simp [hchild_full]; omega
    intro h; rw [h] at hlen; simp at hlen; omega
  dsimp [splitChild]; rw [dif_pos h_lt]
  have h_get : children[i] = node cKeys cChildren := by simpa using hchild_eq
  rw [h_get]; dsimp; rw [if_pos hchild_full]
  cases hk : cKeys.splitAt (t - 1) with
  | mk leftKeys keysRest =>
    have h_keysRest_nonempty : keysRest ≠ [] := by
      have : (cKeys.splitAt (t - 1)).2 = keysRest := by rw [hk]
      rw [← this]; exact h_keys_snd_nonempty
    cases hkr : keysRest with
    | nil => exact (h_keysRest_nonempty hkr).elim
    | cons medianKey rightKeys =>
      cases hc : cChildren.splitAt t with
      | mk leftCh rightCh =>
        show Sorted (BTree.node (take i keys ++ medianKey :: drop i keys)
          (take i children ++ [BTree.node leftKeys leftCh, BTree.node rightKeys rightCh] ++
            drop (i + 1) children))
        unfold Sorted at h_sorted; rcases h_sorted with ⟨h_keys_pairwise, h_children_sorted⟩
        have hchild_sorted : Sorted (BTree.node cKeys cChildren) := by
          rw [← hchild_eq]; apply h_children_sorted; apply List.get_mem
        unfold Sorted at hchild_sorted
        rcases hchild_sorted with ⟨h_cKeys_pairwise, h_cChildren_sorted⟩
        -- Children sorted: same pattern as occupancy sub-node proof
        have h_newChildren_sorted : ∀ child ∈ (take i children ++
            [BTree.node leftKeys leftCh, BTree.node rightKeys rightCh] ++
            drop (i + 1) children), Sorted child := by
          intro child hchild
          have h_or := List.mem_append.mp hchild
          rcases h_or with (h_take_or_new | h_drop)
          · have h_or2 := List.mem_append.mp h_take_or_new
            rcases h_or2 with (h_take | h_new)
            · have hmem : child ∈ children := (take_sublist i children).subset h_take
              exact h_children_sorted child hmem
            · simp at h_new; rcases h_new with (rfl | rfl)
              · unfold Sorted
                have h_lk : leftKeys = cKeys.take (t-1) := by
                  calc
                    leftKeys = (cKeys.splitAt (t-1)).1 := by rw [hk]
                    _ = cKeys.take (t-1) := by simp
                have h_left_pairwise : List.Pairwise (· ≤ ·) leftKeys := by
                  rw [h_lk]; exact List.Pairwise.take (i := t-1) h_cKeys_pairwise
                refine ⟨h_left_pairwise, ?_⟩
                intro c hc_mem
                have h_left_eq : leftCh = cChildren.take t := by
                  calc
                    leftCh = (cChildren.splitAt t).1 := by rw [hc]
                    _ = cChildren.take t := by simp
                rw [h_left_eq] at hc_mem
                apply h_cChildren_sorted
                exact (take_sublist t cChildren).subset hc_mem
              · unfold Sorted
                have h_rk : rightKeys = cKeys.drop t := by
                  calc
                    rightKeys = keysRest.drop 1 := by rw [hkr]; simp
                    _ = (cKeys.splitAt (t-1)).2.drop 1 := by rw [hk]
                    _ = (cKeys.drop (t-1)).drop 1 := by simp
                    _ = cKeys.drop ((t-1)+1) := by rw [← List.drop_drop]
                    _ = cKeys.drop t := by rw [show (t-1)+1 = t by omega]
                have h_right_pairwise : List.Pairwise (· ≤ ·) rightKeys := by
                  rw [h_rk]; exact List.Pairwise.drop (i := t) h_cKeys_pairwise
                refine ⟨h_right_pairwise, ?_⟩
                intro c hc_mem
                have h_right_eq : rightCh = cChildren.drop t := by
                  calc
                    rightCh = (cChildren.splitAt t).2 := by rw [hc]
                    _ = cChildren.drop t := by simp
                rw [h_right_eq] at hc_mem
                apply h_cChildren_sorted
                exact (drop_sublist t cChildren).subset hc_mem
          · have hmem : child ∈ children := (drop_sublist (i+1) children).subset h_drop
            exact h_children_sorted child hmem
        -- Keys pairwise: proved using pairwise_get_mono + ChildBounded bounds + pairwise_append.
        have h_keys_ok : List.Pairwise (· ≤ ·) (take i keys ++ medianKey :: drop i keys) := by
          -- pairwise properties of the two parts
          have h_take_pw : List.Pairwise (· ≤ ·) (take i keys) :=
            List.Pairwise.take (i := i) h_keys_pairwise
          have h_drop_pw : List.Pairwise (· ≤ ·) (drop i keys) :=
            List.Pairwise.drop (i := i) h_keys_pairwise
          -- cross-bound from original pairwise
          have h_keys_eq : take i keys ++ drop i keys = keys := by simp
          have h_pw_app : List.Pairwise (· ≤ ·) (take i keys ++ drop i keys) := by
            rw [h_keys_eq]; exact h_keys_pairwise
          have h_full := (List.pairwise_append (l₁ := take i keys) (l₂ := drop i keys)).mp h_pw_app
          rcases h_full with ⟨_, _, h_cross⟩
          -- medianKey is in cKeys (from the split)
          have h_median_in_cKeys : medianKey ∈ cKeys := by
            have h_cKeys_eq : cKeys = leftKeys ++ medianKey :: rightKeys := by
              calc
                cKeys = cKeys.take (t-1) ++ cKeys.drop (t-1) := by simp
                _ = (cKeys.splitAt (t-1)).1 ++ (cKeys.splitAt (t-1)).2 := by simp
                _ = leftKeys ++ keysRest := by rw [hk]
                _ = leftKeys ++ (medianKey :: rightKeys) := by rw [hkr]
            rw [h_cKeys_eq]; simp
          have h_median_mem : medianKey ∈ keysOf (BTree.node cKeys cChildren) := by
            unfold keysOf; simp [h_median_in_cKeys]
          -- Extract ChildBounded bounds (unfold once, using REPL-proven pattern)
          unfold ChildBounded at h_cb
          rcases h_cb with ⟨h_cb_rel, h_cb_bounds, _⟩
          have h_ilen : children.length = keys.length + 1 := by
            rcases h_cb_rel with (h_empty | h_eq)
            · exfalso
              have hlen0 : children.length = 0 := by simpa using h_empty
              rw [hlen0] at h_lt; exact Nat.not_lt_zero i h_lt
            · exact h_eq
          rcases h_cb_bounds i h_lt with ⟨h_lo_raw, h_hi_raw⟩
          have hi_le : i ≤ keys.length := by rw [h_ilen] at h_lt; omega
          have hchild_eq_get : children[i] = BTree.node cKeys cChildren := by simpa using hchild_eq
          -- lower bound (when i>0): keys[i-1] ≤ medianKey
          have h_lower (hi_pos : 0 < i) (hi_sub : i-1 < keys.length) :
              keys.get ⟨i-1, hi_sub⟩ ≤ medianKey := by
            rcases h_lo_raw with (hi0 | h_lo_match)
            · exact (Nat.ne_of_gt hi_pos hi0).elim
            · simp [hi_sub] at h_lo_match
              rw [hchild_eq_get] at h_lo_match
              exact h_lo_match medianKey h_median_mem
          -- Two cases: i < keys.length or i = keys.length
          by_cases hi_len : i < keys.length
          · -- i < keys.length: the upper bound keys[i] exists
            have h_upper_val : medianKey ≤ keys.get ⟨i, hi_len⟩ := by
              simp [hi_len] at h_hi_raw
              rw [hchild_eq_get] at h_hi_raw
              exact h_hi_raw medianKey h_median_mem
            -- Build take i keys ++ [medianKey] pairwise
            have h_take_le : ∀ a ∈ take i keys, a ≤ medianKey := by
              intro a ha
              rcases List.mem_iff_get.mp ha with ⟨n, h_eq⟩
              -- n : Fin (take i keys).length, so n.val < i (since length ≤ i)
              have hn_val_lt_i : n.val < i :=
                calc n.val < (take i keys).length := n.isLt
                _ ≤ i := by simp
              have hn_len : n.val < keys.length :=
                calc n.val < (take i keys).length := n.isLt
                _ ≤ keys.length := by simp
              -- (take i keys).get n = keys.get ⟨n.val, hn_len⟩
              have h_val : a = keys.get ⟨n.val, hn_len⟩ := by
                calc a = (take i keys).get n := by rw [h_eq]
                _ = keys.get ⟨n.val, hn_len⟩ := by simp
              rw [h_val]
              -- keys[j] ≤ keys[i-1] (pairwise, j < i) ≤ medianKey (h_lower)
              by_cases hi0 : i = 0
              · subst hi0; omega
              · have hi_pos : 0 < i := Nat.pos_of_ne_zero hi0
                have hi_sub : i-1 < keys.length := by omega
                have h_pw : keys.get ⟨n.val, hn_len⟩ ≤ keys.get ⟨i-1, hi_sub⟩ :=
                  pairwise_get_mono h_keys_pairwise (by omega) hn_len hi_sub
                exact Nat.le_trans h_pw (h_lower hi_pos hi_sub)
            -- Build medianKey ≤ ∀ b ∈ drop i keys
            have h_drop_le : ∀ b ∈ drop i keys, medianKey ≤ b := by
              intro b hb
              rcases List.mem_iff_get.mp hb with ⟨n, h_eq⟩
              -- n : Fin (drop i keys).length
              -- (drop i keys).get n = keys.get ⟨i + n.val, ...⟩
              have hn_total_len : i + n.val < keys.length := by
                have : (drop i keys).length = keys.length - i := by simp
                have : n.val < keys.length - i := by
                  rw [← this]; exact n.isLt
                omega
              have h_val : b = keys.get ⟨i + n.val, hn_total_len⟩ := by
                calc b = (drop i keys).get n := by rw [h_eq]
                _ = keys.get ⟨i + n.val, hn_total_len⟩ := by simp
              rw [h_val]
              -- medianKey ≤ keys[i] (h_upper_val) ≤ keys[i + n.val] (pairwise, i ≤ i+n.val)
              have h_pw : keys.get ⟨i, hi_len⟩ ≤ keys.get ⟨i + n.val, hn_total_len⟩ :=
                pairwise_get_mono h_keys_pairwise (by omega) hi_len hn_total_len
              exact Nat.le_trans h_upper_val h_pw
            -- Assemble with pairwise_append
            have h_singleton : List.Pairwise (· ≤ ·) [medianKey] := by simp
            have h_prefix : List.Pairwise (· ≤ ·) (take i keys ++ [medianKey]) :=
              (List.pairwise_append (l₁ := take i keys) (l₂ := [medianKey])).mpr
                ⟨h_take_pw, h_singleton, λ a ha b hb => by
                  simp at hb; subst hb; exact h_take_le a ha⟩
            -- Need to rewrite the goal to match pairwise_append's l₁ ++ l₂ pattern
            have h_assoc : take i keys ++ medianKey :: drop i keys = (take i keys ++ [medianKey]) ++ drop i keys := by simp
            rw [h_assoc]
            exact ((List.pairwise_append (l₁ := take i keys ++ [medianKey]) (l₂ := drop i keys)).mpr
              ⟨h_prefix, h_drop_pw, λ a ha b hb => by
                rw [List.mem_append] at ha; rcases ha with (ha | ha)
                · exact h_cross a ha b hb
                · simp at ha; subst ha; exact h_drop_le b hb⟩)
          · -- i = keys.length: no upper bound key, drop i keys = []
            have hi_eq : i = keys.length := by omega
            have h_drop_empty : drop i keys = [] := by rw [hi_eq]; simp
            rw [h_drop_empty]
            -- Goal: List.Pairwise (· ≤ ·) (take i keys ++ medianKey :: [])
            -- medianKey :: [] = [medianKey]
            have h_cons_nil : medianKey :: [] = [medianKey] := by simp
            rw [h_cons_nil]
            -- Goal: List.Pairwise (· ≤ ·) (take i keys ++ [medianKey])
            -- Same as the h_prefix proof above, but we use h_take_pw from the outer scope
            have h_take_le : ∀ a ∈ take i keys, a ≤ medianKey := by
              intro a ha
              rcases List.mem_iff_get.mp ha with ⟨n, h_eq⟩
              have hn_len : n.val < keys.length :=
                Nat.lt_of_lt_of_le n.isLt (by simp)
              have h_val : a = keys.get ⟨n.val, hn_len⟩ := by
                calc a = (take i keys).get n := by rw [h_eq]
                _ = keys.get ⟨n.val, hn_len⟩ := by simp
              rw [h_val]
              by_cases hi0 : i = 0
              · subst hi0; omega
              · have hi_pos : 0 < i := Nat.pos_of_ne_zero hi0
                have hi_sub : i-1 < keys.length := by omega
                have h_pw : keys.get ⟨n.val, hn_len⟩ ≤ keys.get ⟨i-1, hi_sub⟩ :=
                  pairwise_get_mono h_keys_pairwise (by omega) hn_len hi_sub
                exact Nat.le_trans h_pw (h_lower hi_pos hi_sub)
            have h_singleton : List.Pairwise (· ≤ ·) [medianKey] := by simp
            exact (List.pairwise_append (l₁ := take i keys) (l₂ := [medianKey])).mpr
              ⟨h_take_pw, h_singleton, λ a ha b hb => by simp at hb; subst hb; exact h_take_le a ha⟩
        unfold Sorted
        refine ⟨h_keys_ok, h_newChildren_sorted⟩

ChildBounded preservation infrastructure

The proof of splitChild_preserves_childBounded relies on:

keysOf_node_subset: the keys of a node built from sublists is a subset.
childBounded_node_nil: a node with no children is trivially bounded.
keysOf_take_le_pivot / keysOf_drop_ge_pivot: the median key sandwiches the two new children (this is the ordering content that needs Sorted).
childBounded_take_of_full / childBounded_drop_of_full: ChildBounded survives truncating a full node's keys/children to a prefix/suffix.

If ks ⊆ ks' and cs ⊆ cs', then the flattened keys of node ks cs are a subset of those of node ks' cs'. This is the user-suggested keysOf_subset lemma, phrased for arbitrary sublists (used for both the left and right split children).

lemma keysOf_node_subset {ks ks' : List Nat} {cs cs' : List BTree}
    (hk : ks ⊆ ks') (hc : cs ⊆ cs') :
    keysOf (node ks cs) ⊆ keysOf (node ks' cs') := by
  intro x hx
  simp only [keysOf, List.mem_append, List.mem_flatMap] at hx ⊢
  rcases hx with hxk | ⟨c, hcm, hxc⟩
  · exact Or.inl (hk hxk)
  · exact Or.inr ⟨c, hc hcm, hxc⟩

A node with no children is trivially ChildBounded.

lemma childBounded_node_nil (ks : List Nat) : ChildBounded (node ks []) := by
  unfold ChildBounded
  refine ⟨Or.inl (by simp), ?_, ?_⟩
  · intro j hj; simp at hj
  · intro c hc; simp at hc

Every key beneath the left split node node (ks.take m) (cs.take (m+1)) is ≤ ks[m] (the median key). Uses sortedness of ks and the child's own ChildBounded upper bounds.


lemma keysOf_take_le_pivot {ks : List Nat} {cs : List BTree} {m : Nat}
    (h_pw : List.Pairwise (· ≤ ·) ks)
    (h_cb : ChildBounded (node ks cs))
    (hm : m < ks.length) :
    ∀ k ∈ keysOf (node (ks.take m) (cs.take (m + 1))), k ≤ ks[m] := by
  intro k hk
  simp only [keysOf, List.mem_append, List.mem_flatMap] at hk
  rcases hk with hk | ⟨c, hc, hkc⟩
  · -- key from the truncated key list: monotone since `ks` is sorted
    rcases List.mem_iff_get.mp hk with ⟨n, h_eq⟩
    have hn_m : n.val < m := Nat.lt_of_lt_of_le n.isLt (List.length_take_le m ks)
    have hn_ks : n.val < ks.length := by omega
    have h_val : k = ks.get ⟨n.val, hn_ks⟩ := by
      calc k = (ks.take m).get n := by rw [h_eq]
        _ = ks.get ⟨n.val, hn_ks⟩ := by simp
    rw [h_val]
    exact pairwise_get_mono h_pw (by omega) hn_ks hm
  · -- key from a child subtree: bounded by `ks[n] ≤ ks[m]`
    rcases List.mem_iff_get.mp hc with ⟨n, h_eq⟩
    have hn_m1 : n.val < m + 1 := Nat.lt_of_lt_of_le n.isLt (List.length_take_le (m + 1) cs)
    have hn_cs : n.val < cs.length := Nat.lt_of_lt_of_le n.isLt (List.length_take_le' (m + 1) cs)
    have hn_ks : n.val < ks.length := by omega
    have hc_eq : c = cs.get ⟨n.val, hn_cs⟩ := by
      calc c = (cs.take (m + 1)).get n := by rw [h_eq]
        _ = cs.get ⟨n.val, hn_cs⟩ := by simp
    unfold ChildBounded at h_cb
    rcases h_cb with ⟨_, h_bounds, _⟩
    have hub := (h_bounds n.val hn_cs).2
    simp only [List.getElem?_eq_getElem hn_ks] at hub
    rw [← hc_eq] at hub
    have h1 : k ≤ ks[n.val] := hub k hkc
    have h2 := pairwise_get_mono h_pw (show n.val ≤ m by omega) hn_ks hm
    simp only [List.get_eq_getElem] at h2
    exact le_trans h1 h2

Every key beneath the right split node node (ks.drop (m+1)) (cs.drop (m+1)) is ≥ ks[m] (the median key). Symmetric to keysOf_take_le_pivot.


lemma keysOf_drop_ge_pivot {ks : List Nat} {cs : List BTree} {m : Nat}
    (h_pw : List.Pairwise (· ≤ ·) ks)
    (h_cb : ChildBounded (node ks cs))
    (hm : m < ks.length) :
    ∀ k ∈ keysOf (node (ks.drop (m + 1)) (cs.drop (m + 1))), ks[m] ≤ k := by
  intro k hk
  simp only [keysOf, List.mem_append, List.mem_flatMap] at hk
  rcases hk with hk | ⟨c, hc, hkc⟩
  · -- key from the truncated key list
    rcases List.mem_iff_get.mp hk with ⟨n, h_eq⟩
    have hn_len : (m + 1) + n.val < ks.length := by
      have h : n.val < ks.length - (m + 1) := by rw [← List.length_drop]; exact n.isLt
      omega
    have h_val : k = ks.get ⟨(m + 1) + n.val, hn_len⟩ := by
      calc k = (ks.drop (m + 1)).get n := by rw [h_eq]
        _ = ks.get ⟨(m + 1) + n.val, hn_len⟩ := by simp
    rw [h_val]
    exact pairwise_get_mono h_pw (by omega) hm hn_len
  · -- key from a child subtree: bounded by `ks[m] ≤ ks[(m+1)+n-1]`
    rcases List.mem_iff_get.mp hc with ⟨n, h_eq⟩
    have hn_cs : (m + 1) + n.val < cs.length := by
      have h : n.val < cs.length - (m + 1) := by rw [← List.length_drop]; exact n.isLt
      omega
    unfold ChildBounded at h_cb
    rcases h_cb with ⟨h_rel, h_bounds, _⟩
    have h_len : cs.length = ks.length + 1 := by
      rcases h_rel with h_empty | h_len
      · have hnil : cs = [] := List.isEmpty_iff.mp h_empty
        have hlen0 : cs.length = 0 := by simp [hnil]
        omega
      · exact h_len
    have hidx : (m + 1) + n.val - 1 < ks.length := by omega
    have hc_eq : c = cs.get ⟨(m + 1) + n.val, hn_cs⟩ := by
      calc c = (cs.drop (m + 1)).get n := by rw [h_eq]
        _ = cs.get ⟨(m + 1) + n.val, hn_cs⟩ := by simp
    have hlb := (h_bounds ((m + 1) + n.val) hn_cs).1
    rcases hlb with h0 | hlbmatch
    · omega
    · simp only [List.getElem?_eq_getElem hidx] at hlbmatch
      rw [← hc_eq] at hlbmatch
      have h1 : ks[(m + 1) + n.val - 1] ≤ k := hlbmatch k hkc
      have h2 := pairwise_get_mono h_pw (show m ≤ (m + 1) + n.val - 1 by omega) hm hidx
      simp only [List.get_eq_getElem] at h2
      exact le_trans h2 h1

ChildBounded survives truncating a node's keys to take m and children to take (m+1) (the left result of a split).


lemma childBounded_take_of_full {ks : List Nat} {cs : List BTree} {m : Nat}
    (h_cb : ChildBounded (node ks cs)) (hm : m < ks.length) :
    ChildBounded (node (ks.take m) (cs.take (m + 1))) := by
  have h_cb' := h_cb
  unfold ChildBounded at h_cb'
  rcases h_cb' with ⟨h_rel, h_bounds, h_sub⟩
  rcases h_rel with h_empty | h_len
  · have hcs : cs = [] := by cases cs with | nil => rfl | cons x xs => simp at h_empty
    subst hcs
    simpa using childBounded_node_nil (ks.take m)
  · unfold ChildBounded
    refine ⟨?_, ?_, ?_⟩
    · right; rw [List.length_take, List.length_take]; omega
    · intro j hj
      have hj_cs : j < cs.length := by have := hj; rw [List.length_take] at this; omega
      have hchild : (cs.take (m + 1)).get ⟨j, hj⟩ = cs.get ⟨j, hj_cs⟩ := by simp
      refine ⟨?_, ?_⟩
      · rcases Nat.eq_zero_or_pos j with hj0 | hjpos
        · exact Or.inl hj0
        · right
          have hj1_m : j - 1 < m := by have := hj; rw [List.length_take] at this; omega
          have hj1_ks : j - 1 < ks.length := by omega
          rw [List.getElem?_take_of_lt hj1_m, List.getElem?_eq_getElem hj1_ks]
          have hlb := (h_bounds j hj_cs).1
          rcases hlb with h0 | hlbmatch
          · omega
          · simp only [List.getElem?_eq_getElem hj1_ks] at hlbmatch
            intro k hk; rw [hchild] at hk; exact hlbmatch k hk
      · by_cases hj_m : j < m
        · have hj_ks : j < ks.length := by omega
          rw [List.getElem?_take_of_lt hj_m, List.getElem?_eq_getElem hj_ks]
          have hub := (h_bounds j hj_cs).2
          simp only [List.getElem?_eq_getElem hj_ks] at hub
          intro k hk; rw [hchild] at hk; exact hub k hk
        · have hnone : (ks.take m)[j]? = none := by
            apply List.getElem?_eq_none; rw [List.length_take]; omega
          rw [hnone]; exact trivial
    · intro c hc
      exact h_sub c ((List.take_subset (m + 1) cs) hc)

ChildBounded survives dropping d keys and d children (the right result of a split, with d = t).


lemma childBounded_drop_of_full {ks : List Nat} {cs : List BTree} {d : Nat}
    (h_cb : ChildBounded (node ks cs)) (hd : 0 < d) (hd_cs : d < cs.length) :
    ChildBounded (node (ks.drop d) (cs.drop d)) := by
  have h_cb' := h_cb
  unfold ChildBounded at h_cb'
  rcases h_cb' with ⟨h_rel, h_bounds, h_sub⟩
  have h_len : cs.length = ks.length + 1 := by
    rcases h_rel with h_empty | h_len
    · have hnil : cs = [] := by cases cs with | nil => rfl | cons x xs => simp at h_empty
      rw [hnil] at hd_cs; simp at hd_cs
    · exact h_len
  unfold ChildBounded
  refine ⟨?_, ?_, ?_⟩
  · right; rw [List.length_drop, List.length_drop]; omega
  · intro j hj
    have hj_len : j < cs.length - d := by have := hj; rw [List.length_drop] at this; exact this
    have hdj_cs : d + j < cs.length := by omega
    have hchild : (cs.drop d).get ⟨j, hj⟩ = cs.get ⟨d + j, hdj_cs⟩ := by simp
    refine ⟨?_, ?_⟩
    · rcases Nat.eq_zero_or_pos j with hj0 | hjpos
      · exact Or.inl hj0
      · right
        have hidx : d + j - 1 < ks.length := by omega
        have heq_idx : d + (j - 1) = d + j - 1 := by omega
        rw [List.getElem?_drop, heq_idx, List.getElem?_eq_getElem hidx]
        have hlb := (h_bounds (d + j) hdj_cs).1
        rcases hlb with h0 | hlbmatch
        · omega
        · simp only [List.getElem?_eq_getElem hidx] at hlbmatch
          intro k hk; rw [hchild] at hk; exact hlbmatch k hk
    · by_cases hdj : d + j < ks.length
      · rw [List.getElem?_drop, List.getElem?_eq_getElem hdj]
        have hub := (h_bounds (d + j) hdj_cs).2
        simp only [List.getElem?_eq_getElem hdj] at hub
        intro k hk; rw [hchild] at hk; exact hub k hk
      · have hnone : (ks.drop d)[j]? = none := by
          rw [List.getElem?_drop]; apply List.getElem?_eq_none; omega
        rw [hnone]; exact trivial
  · intro c hc
    exact h_sub c ((List.drop_subset d cs) hc)

B-TREE-SPLIT-CHILD preserves ChildBounded. Splitting a full child of a non-full node keeps the key-range invariant: the promoted median key becomes a new separator that sandwiches the two halves, and every other separator/child relation is inherited from the original tree.


theorem splitChild_preserves_childBounded (t : Nat) (ht : 2 ≤ t)
    (keys : List Nat) (children : List BTree)
    (cKeys : List Nat) (cChildren : List BTree) (i : Nat)
    (h_lt : i < children.length)
    (hchild_eq : children.get ⟨i, h_lt⟩ = node cKeys cChildren)
    (hchild_full : cKeys.length = 2 * t - 1)
    (h_cb : ChildBounded (node keys children))
    (h_sorted : Sorted (node keys children)) :
    ChildBounded (splitChild t (node keys children) i) := by
  -- Extract the parent's ChildBounded components.
  have h_cb' := h_cb
  unfold ChildBounded at h_cb'
  obtain ⟨h_cb_rel, h_cb_bounds, h_cb_sub⟩ := h_cb'
  have h_ch_len : children.length = keys.length + 1 := by
    rcases h_cb_rel with h_empty | h_eq
    · have hnil : children = [] := List.isEmpty_iff.mp h_empty
      have : children.length = 0 := by simp [hnil]
      omega
    · exact h_eq
  have h_i_le_keys : i ≤ keys.length := by omega
  -- Unfold `splitChild` (same pattern as `splitChild_preserves_sorted`).
  have h_keys_snd_nonempty : (cKeys.splitAt (t - 1)).2 ≠ [] := by
    have hlen : (cKeys.splitAt (t - 1)).2.length = t := by simp [hchild_full]; omega
    intro h; rw [h] at hlen; simp at hlen; omega
  dsimp [splitChild]; rw [dif_pos h_lt]
  have h_get : children[i] = node cKeys cChildren := by simpa using hchild_eq
  rw [h_get]; dsimp; rw [if_pos hchild_full]
  cases hk : cKeys.splitAt (t - 1) with
  | mk leftKeys keysRest =>
    have h_keysRest_nonempty : keysRest ≠ [] := by
      have : (cKeys.splitAt (t - 1)).2 = keysRest := by rw [hk]
      rw [← this]; exact h_keys_snd_nonempty
    cases hkr : keysRest with
    | nil => exact (h_keysRest_nonempty hkr).elim
    | cons medianKey rightKeys =>
      cases hc : cChildren.splitAt t with
      | mk leftCh rightCh =>
        show ChildBounded (BTree.node (take i keys ++ medianKey :: drop i keys)
          (take i children ++ [BTree.node leftKeys leftCh, BTree.node rightKeys rightCh] ++
            drop (i + 1) children))
        -- Relate the local split names to `take`/`drop` of the child's keys/children.
        have h_lk : leftKeys = cKeys.take (t - 1) := by
          calc leftKeys = (cKeys.splitAt (t - 1)).1 := by rw [hk]
            _ = cKeys.take (t - 1) := by simp
        have h_keysRest_eq : keysRest = cKeys.drop (t - 1) := by
          calc keysRest = (cKeys.splitAt (t - 1)).2 := by rw [hk]
            _ = cKeys.drop (t - 1) := by simp
        have h_rk : rightKeys = cKeys.drop t := by
          calc rightKeys = keysRest.drop 1 := by rw [hkr]; simp
            _ = (cKeys.drop (t - 1)).drop 1 := by rw [h_keysRest_eq]
            _ = cKeys.drop ((t - 1) + 1) := by rw [← List.drop_drop]
            _ = cKeys.drop t := by rw [show (t - 1) + 1 = t from by omega]
        have h_left_eq : leftCh = cChildren.take t := by
          calc leftCh = (cChildren.splitAt t).1 := by rw [hc]
            _ = cChildren.take t := by simp
        have h_right_eq : rightCh = cChildren.drop t := by
          calc rightCh = (cChildren.splitAt t).2 := by rw [hc]
            _ = cChildren.drop t := by simp
        have h_t1_lt : t - 1 < cKeys.length := by omega
        have h_median : cKeys[t - 1]? = some medianKey := by
          have hh : (cKeys.drop (t - 1))[0]? = some medianKey := by
            rw [← h_keysRest_eq, hkr]; rfl
          rw [List.getElem?_drop] at hh; simpa using hh
        have h_median_eq : medianKey = cKeys[t - 1] := by
          rw [List.getElem?_eq_getElem h_t1_lt] at h_median
          injection h_median with h_median; exact h_median.symm
        -- Child invariants.
        have h_child_cb : ChildBounded (node cKeys cChildren) := by
          rw [← hchild_eq]; apply h_cb_sub; apply List.get_mem
        have h_cKeys_pw : List.Pairwise (· ≤ ·) cKeys := by
          have h_cs : Sorted (node cKeys cChildren) := by
            rw [← hchild_eq]
            unfold Sorted at h_sorted; rcases h_sorted with ⟨_, h_sc⟩
            apply h_sc; apply List.get_mem
          unfold Sorted at h_cs; exact h_cs.1
        have h_cChildren_len := child_children_len_of_full_cb ht h_child_cb hchild_full
        -- The median key sandwiches the two new children.
        have h_left_le : ∀ k ∈ keysOf (node leftKeys leftCh), k ≤ medianKey := by
          intro k hk
          rw [h_lk, h_left_eq] at hk
          rw [h_median_eq]
          have hp := keysOf_take_le_pivot h_cKeys_pw h_child_cb h_t1_lt
          rw [show (t - 1) + 1 = t from by omega] at hp
          exact hp k hk
        have h_right_ge : ∀ k ∈ keysOf (node rightKeys rightCh), medianKey ≤ k := by
          intro k hk
          rw [h_rk, h_right_eq] at hk
          rw [h_median_eq]
          have hp := keysOf_drop_ge_pivot h_cKeys_pw h_child_cb h_t1_lt
          rw [show (t - 1) + 1 = t from by omega] at hp
          exact hp k hk
        -- The two new children are themselves ChildBounded.
        have h_cb_left : ChildBounded (node leftKeys leftCh) := by
          have hh := childBounded_take_of_full h_child_cb h_t1_lt
          rw [show (t - 1) + 1 = t from by omega] at hh
          rw [h_lk, h_left_eq]; exact hh
        have h_cb_right : ChildBounded (node rightKeys rightCh) := by
          rcases h_cChildren_len with h0 | h2t
          · have hnil : cChildren = [] := by
              cases cChildren with | nil => rfl | cons x xs => simp at h0
            have hrc : rightCh = [] := by rw [h_right_eq, hnil]; simp
            rw [hrc]; exact childBounded_node_nil rightKeys
          · have hd_cs : t < cChildren.length := by rw [h2t]; omega
            have hh := childBounded_drop_of_full h_child_cb (by omega) hd_cs
            rw [h_rk, h_right_eq]; exact hh
        -- `newKeys[·]?` computed by position relative to the inserted median.
        have h_P_len : (take i keys).length = i := by rw [List.length_take]; omega
        have hNK_lt : ∀ j', j' < i →
            (take i keys ++ medianKey :: drop i keys)[j']? = keys[j']? := by
          intro j' hj'
          rw [List.getElem?_append_left (by rw [h_P_len]; exact hj'), List.getElem?_take_of_lt hj']
        have hNK_eq : (take i keys ++ medianKey :: drop i keys)[i]? = some medianKey := by
          rw [List.getElem?_append_right (le_of_eq h_P_len), h_P_len]; simp
        have hNK_gt : ∀ j', i < j' →
            (take i keys ++ medianKey :: drop i keys)[j']? = keys[j' - 1]? := by
          intro j' hj'
          rw [List.getElem?_append_right (by rw [h_P_len]; omega), h_P_len,
              show j' - i = (j' - i - 1) + 1 from by omega, List.getElem?_cons_succ,
              List.getElem?_drop, show i + (j' - i - 1) = j' - 1 from by omega]
        unfold ChildBounded
        refine ⟨?_, ?_, ?_⟩
        · -- Count relation.
          right
          simp only [List.length_append, List.length_cons, List.length_nil,
            List.length_take, List.length_drop]
          omega
        · -- Parent key-range bounds.
          have h_A_len : (take i children).length = i := by rw [List.length_take]; omega
          have h_AB_len : (take i children ++
              [node leftKeys leftCh, node rightKeys rightCh]).length = i + 2 := by
            simp [List.length_append, h_A_len]
          have h_nc_len : (take i children ++
              [node leftKeys leftCh, node rightKeys rightCh] ++ drop (i + 1) children).length
              = children.length + 1 := by
            simp only [List.length_append, List.length_cons, List.length_nil,
              List.length_take, List.length_drop]
            omega
          have hsub_left : keysOf (node leftKeys leftCh) ⊆ keysOf (node cKeys cChildren) :=
            keysOf_node_subset (by rw [h_lk]; exact List.take_subset _ _)
              (by rw [h_left_eq]; exact List.take_subset _ _)
          have hsub_right : keysOf (node rightKeys rightCh) ⊆ keysOf (node cKeys cChildren) :=
            keysOf_node_subset (by rw [h_rk]; exact List.drop_subset _ _)
              (by rw [h_right_eq]; exact List.drop_subset _ _)
          intro j hj
          have hj' : j < children.length + 1 := h_nc_len ▸ hj
          rcases Nat.lt_trichotomy j i with hlt | heq | hgt
          · -- Region 1: `j < i` — unchanged left children.
            have hj_ch : j < children.length := by omega
            have hlt_AB : j < (take i children ++
                [node leftKeys leftCh, node rightKeys rightCh]).length := by rw [h_AB_len]; omega
            have hlt_A : j < (take i children).length := by rw [h_A_len]; omega
            have hchild : (take i children ++ [node leftKeys leftCh, node rightKeys rightCh] ++
                drop (i + 1) children).get ⟨j, hj⟩ = children.get ⟨j, hj_ch⟩ := by
              simp only [List.get_eq_getElem]
              rw [List.getElem_append_left hlt_AB, List.getElem_append_left hlt_A]; simp
            refine ⟨?_, ?_⟩
            · rcases Nat.eq_zero_or_pos j with hj0 | hjpos
              · exact Or.inl hj0
              · right
                rw [hNK_lt (j - 1) (by omega), hchild]
                rcases (h_cb_bounds j hj_ch).1 with h0 | hbmatch
                · omega
                · exact hbmatch
            · rw [hNK_lt j hlt, hchild]
              exact (h_cb_bounds j hj_ch).2
          · -- Region 2: `j = i` — the new left child.
            have hlt_AB : j < (take i children ++
                [node leftKeys leftCh, node rightKeys rightCh]).length := by rw [h_AB_len]; omega
            have hge_A : (take i children).length ≤ j := by rw [h_A_len]; omega
            have hchild : (take i children ++ [node leftKeys leftCh, node rightKeys rightCh] ++
                drop (i + 1) children).get ⟨j, hj⟩ = node leftKeys leftCh := by
              simp only [List.get_eq_getElem]
              rw [List.getElem_append_left hlt_AB, List.getElem_append_right hge_A]
              simp [h_A_len, show j - i = 0 from by omega]
            refine ⟨?_, ?_⟩
            · rcases Nat.eq_zero_or_pos j with hj0 | hjpos
              · exact Or.inl hj0
              · right
                rw [hNK_lt (j - 1) (by omega), hchild, show j - 1 = i - 1 from by omega]
                have hb := (h_cb_bounds i h_lt).1
                rw [hchild_eq] at hb
                rcases hb with h0 | hbmatch
                · omega
                · revert hbmatch
                  cases keys[i - 1]? with
                  | none => intro _; trivial
                  | some lo => intro hbmatch; exact fun k hk => hbmatch k (hsub_left hk)
            · have hjk : (take i keys ++ medianKey :: drop i keys)[j]? = some medianKey := by
                rw [show j = i from heq]; exact hNK_eq
              rw [hjk, hchild]; exact h_left_le
          · rcases Nat.lt_or_ge j (i + 2) with hj2 | hj2
            · -- Region 3: `j = i + 1` — the new right child.
              have hlt_AB : j < (take i children ++
                  [node leftKeys leftCh, node rightKeys rightCh]).length := by rw [h_AB_len]; omega
              have hge_A : (take i children).length ≤ j := by rw [h_A_len]; omega
              have hchild : (take i children ++ [node leftKeys leftCh, node rightKeys rightCh] ++
                  drop (i + 1) children).get ⟨j, hj⟩ = node rightKeys rightCh := by
                simp only [List.get_eq_getElem]
                rw [List.getElem_append_left hlt_AB, List.getElem_append_right hge_A]
                simp [h_A_len, show j - i = 1 from by omega]
              refine ⟨?_, ?_⟩
              · right
                rw [show j - 1 = i from by omega, hNK_eq, hchild]
                exact h_right_ge
              · rw [hNK_gt j (by omega), show j - 1 = i from by omega, hchild]
                have hb := (h_cb_bounds i h_lt).2
                rw [hchild_eq] at hb
                revert hb
                cases keys[i]? with
                | none => intro _; trivial
                | some hi => intro hb; exact fun k hk => hb k (hsub_right hk)
            · -- Region 4: `j ≥ i + 2` — unchanged right children (shifted by one).
              have hj1_ch : j - 1 < children.length := by omega
              have hge_AB : (take i children ++
                  [node leftKeys leftCh, node rightKeys rightCh]).length ≤ j := by
                rw [h_AB_len]; omega
              have hchild : (take i children ++ [node leftKeys leftCh, node rightKeys rightCh] ++
                  drop (i + 1) children).get ⟨j, hj⟩ = children.get ⟨j - 1, hj1_ch⟩ := by
                simp only [List.get_eq_getElem]
                rw [List.getElem_append_right hge_AB]
                simp only [h_AB_len, List.getElem_drop,
                  show (i + 1) + (j - (i + 2)) = j - 1 from by omega]
              refine ⟨?_, ?_⟩
              · right
                rw [hNK_gt (j - 1) (by omega), hchild]
                rcases (h_cb_bounds (j - 1) hj1_ch).1 with h0 | hbmatch
                · omega
                · exact hbmatch
              · rw [hNK_gt j (by omega), hchild]
                exact (h_cb_bounds (j - 1) hj1_ch).2
        · -- Recursive ChildBounded of every new child.
          intro child hchild
          rcases List.mem_append.mp hchild with h_take_new | h_drop
          · rcases List.mem_append.mp h_take_new with h_take | h_new
            · exact h_cb_sub child ((List.take_subset i children) h_take)
            · simp at h_new; rcases h_new with rfl | rfl
              · exact h_cb_left
              · exact h_cb_right
          · exact h_cb_sub child ((List.drop_subset (i + 1) children) h_drop)

B-TREE-SPLIT-CHILD preserves WellFormed. Splitting a full child i of a non-full node keeps all four structural invariants simultaneously. This is the capstone that combines splitChild_preserves_sorted, splitChild_preserves_childBounded, splitChild_preserves_occupancy, and splitChild_preserves_sameDepth. The side condition cChildren = [] ∨ t < cChildren.length needed by the SameDepth lemma is derived from the child's own ChildBounded invariant.


theorem splitChild_preserves_wellFormed (t : Nat) (ht : 2 ≤ t)
    (keys : List Nat) (children : List BTree)
    (cKeys : List Nat) (cChildren : List BTree) (i : Nat)
    (h_lt : i < children.length)
    (hchild_eq : children.get ⟨i, h_lt⟩ = node cKeys cChildren)
    (hchild_full : cKeys.length = 2 * t - 1)
    (hparent_nonfull : keys.length < 2 * t - 1)
    (h_wf : WellFormed t (node keys children)) :
    WellFormed t (splitChild t (node keys children) i) := by
  obtain ⟨h_sorted, h_cb, h_occ, h_sd⟩ := h_wf
  -- The split child is itself `ChildBounded`, so its child count is `0` or `2t`.
  have h_child_cb : ChildBounded (node cKeys cChildren) := by
    rw [← hchild_eq]
    have hcb := h_cb
    unfold ChildBounded at hcb; rcases hcb with ⟨_, _, h_sub⟩
    apply h_sub; apply List.get_mem
  have hchild_children : cChildren = [] ∨ t < cChildren.length := by
    rcases child_children_len_of_full_cb ht h_child_cb hchild_full with h0 | h2t
    · left; cases cChildren with | nil => rfl | cons x xs => simp at h0
    · right; rw [h2t]; omega
  exact ⟨splitChild_preserves_sorted t ht keys children cKeys cChildren i h_lt hchild_eq
            hchild_full h_sorted h_cb,
         splitChild_preserves_childBounded t ht keys children cKeys cChildren i h_lt hchild_eq
            hchild_full h_cb h_sorted,
         splitChild_preserves_occupancy t ht keys children cKeys cChildren i h_lt hchild_eq
            hchild_full hparent_nonfull h_occ h_cb,
         splitChild_preserves_sameDepth t ht keys children cKeys cChildren i h_lt hchild_eq
            hchild_full hchild_children h_sd⟩

B-TREE-SPLIT-CHILD preserves the key multiset. Splitting a full child neither loses nor introduces keys: the flattened key list of the result is a permutation of the original. No ordering hypotheses are needed — this is a pure contents fact, complementing the structural-invariant theorems above.


theorem splitChild_keys_perm (t : Nat) (ht : 2 ≤ t)
    (keys : List Nat) (children : List BTree)
    (cKeys : List Nat) (cChildren : List BTree) (i : Nat)
    (h_lt : i < children.length)
    (hchild_eq : children.get ⟨i, h_lt⟩ = node cKeys cChildren)
    (hchild_full : cKeys.length = 2 * t - 1) :
    (keysOf (splitChild t (node keys children) i)).Perm (keysOf (node keys children)) := by
  have h_keys_snd_nonempty : (cKeys.splitAt (t - 1)).2 ≠ [] := by
    have hlen : (cKeys.splitAt (t - 1)).2.length = t := by simp [hchild_full]; omega
    intro h; rw [h] at hlen; simp at hlen; omega
  dsimp [splitChild]; rw [dif_pos h_lt]
  have h_get : children[i] = node cKeys cChildren := by simpa using hchild_eq
  rw [h_get]; dsimp; rw [if_pos hchild_full]
  cases hk : cKeys.splitAt (t - 1) with
  | mk leftKeys keysRest =>
    have h_keysRest_nonempty : keysRest ≠ [] := by
      have : (cKeys.splitAt (t - 1)).2 = keysRest := by rw [hk]
      rw [← this]; exact h_keys_snd_nonempty
    cases hkr : keysRest with
    | nil => exact (h_keysRest_nonempty hkr).elim
    | cons medianKey rightKeys =>
      cases hc : cChildren.splitAt t with
      | mk leftCh rightCh =>
        show (keysOf (BTree.node (take i keys ++ medianKey :: drop i keys)
          (take i children ++ [BTree.node leftKeys leftCh, BTree.node rightKeys rightCh] ++
            drop (i + 1) children))).Perm (keysOf (node keys children))
        have h_lk : leftKeys = cKeys.take (t - 1) := by
          calc leftKeys = (cKeys.splitAt (t - 1)).1 := by rw [hk]
            _ = cKeys.take (t - 1) := by simp
        have h_keysRest_eq : keysRest = cKeys.drop (t - 1) := by
          calc keysRest = (cKeys.splitAt (t - 1)).2 := by rw [hk]
            _ = cKeys.drop (t - 1) := by simp
        have h_left_eq : leftCh = cChildren.take t := by
          calc leftCh = (cChildren.splitAt t).1 := by rw [hc]
            _ = cChildren.take t := by simp
        have h_right_eq : rightCh = cChildren.drop t := by
          calc rightCh = (cChildren.splitAt t).2 := by rw [hc]
            _ = cChildren.drop t := by simp
        -- The three list decompositions that make the multiset match up.
        have h_cKeys_decomp : cKeys = leftKeys ++ medianKey :: rightKeys := by
          conv_lhs => rw [← List.take_append_drop (t - 1) cKeys]
          rw [← h_lk, ← h_keysRest_eq, hkr]
        have h_cChildren_decomp : cChildren = leftCh ++ rightCh := by
          conv_lhs => rw [← List.take_append_drop t cChildren]
          rw [← h_left_eq, ← h_right_eq]
        have h_children_decomp :
            children = take i children ++ node cKeys cChildren :: drop (i + 1) children := by
          conv_lhs => rw [← List.take_append_drop i children]
          rw [List.drop_eq_getElem_cons h_lt, h_get]
        -- Reduce the permutation to a multiset equality and linearise both sides.
        rw [← Multiset.coe_eq_coe]
        conv_rhs => rw [keysOf, h_children_decomp]
        conv_lhs => rw [keysOf]
        simp only [List.flatMap_append, List.flatMap_cons, List.flatMap_nil, List.append_nil,
          keysOf, h_cKeys_decomp, h_cChildren_decomp, ← Multiset.coe_add, This simp argument is unused:
  ← Multiset.coe_nil

Hint: Omit it from the simp argument list.
  simp only [List.flatMap_append, List.flatMap_cons, List.flatMap_nil, List.append_nil,
            keysOf, h_cKeys_decomp, h_cChildren_decomp, ← Multiset.coe_add, ← Multiset.con̲s̲_̲c̲o̲e_̵n̵i̵l̵,
            ← Multiset.c̵o̵n̵s_̵c̵o̵e̵,̵ ̵←̵ ̵M̵u̵l̵t̵is̵e̵t̵.̵s̵i̵ngleton_add]

Note: Simp arguments with `←` have the additional effect of removing the other direction from the simp set, even if the simp argument itself is unused. If the hint above does not work, try replacing `←` with `-` to only get that effect and silence this warning.

Note: This linter can be disabled with `set_option linter.unusedSimpArgs false`← Multiset.coe_nil,
          ← Multiset.cons_coe, ← Multiset.singleton_add]
        rw [show (↑keys : Multiset Nat) = ↑(take i keys) + ↑(drop i keys) from by
          rw [Multiset.coe_add, List.take_append_drop]]
        abel

              end BTreeend Chapter18end CLRS

Definitions and proofs

CLRSLean.FourthEdition.Chapter_18.Section_18_1_B_Tree_Model.HeightBound

CLRS Section 18.1 - B-tree key count and height bound

This module counts every key slot represented by a B-tree. Its exact accounting identity rewrites an internal node's augmented key count as the sum of the augmented counts of its children. That recurrence is the arithmetic foundation for the structural minimum-key and logarithmic-height bounds.

              namespace CLRSnamespace Chapter18namespace BTree

Exact key accounting

The number of key slots represented by a B-tree.

def totalKeys (tr : BTree) : Nat :=
  (keysOf tr).length

A node's total key count is its local key count plus all child counts.

theorem totalKeys_node (ks : List Nat) (cs : List BTree) :
    totalKeys (node ks cs) =
      ks.length + (cs.map totalKeys).sum := by
  unfold totalKeys
  simp [keysOf, List.length_flatMap]

For an internal node, adding one to the total key count exactly absorbs every separator key into one augmented count per child.


private lemma totalKeys_add_one_eq_sum_children
    {ks : List Nat} {c0 : BTree} {cs : List BTree}
    (hcb : ChildBounded (node ks (c0 :: cs))) :
    totalKeys (node ks (c0 :: cs)) + 1 =
      ((c0 :: cs).map (fun child => totalKeys child + 1)).sum := by
  have hlen : (c0 :: cs).length = ks.length + 1 := by
    unfold ChildBounded at hcb
    simpa using hcb.1
  rw [totalKeys_node, List.sum_map_add, List.map_const', List.sum_const_nat]
  simp only [Nat.mul_one]
  omega

A pointwise lower bound lifts to the sum over all list positions.


private lemma length_mul_le_sum_map
    {α : Type} (xs : List α) (q : Nat) (f : α → Nat)
    (hpoint : ∀ x ∈ xs, q ≤ f x) :
    xs.length * q ≤ (xs.map f).sum := by
  have hsum : (xs.map (fun _ => q)).sum ≤ (xs.map f).sum :=
    List.sum_le_sum hpoint
  rw [List.map_const', List.sum_const_nat] at hsum
  exact hsum

Internal-child projections

Every child position of a child-bounded internal node is child-bounded.

private lemma childBounded_of_mem
    {ks : List Nat} {c0 child : BTree} {cs : List BTree}
    (hcb : ChildBounded (node ks (c0 :: cs)))
    (hc : child ∈ c0 :: cs) :
    ChildBounded child := by
  unfold ChildBounded at hcb
  exact hcb.2.2 child hc

Every child position of an occupied node satisfies non-root occupancy.

private lemma occupancy_false_of_mem
    {t : Nat} {isRoot : Bool} {ks : List Nat} {c0 child : BTree}
    {cs : List BTree}
    (hocc : Occupancy t isRoot (node ks (c0 :: cs)))
    (hc : child ∈ c0 :: cs) :
    Occupancy t false child := by
  unfold Occupancy at hocc
  exact hocc.2.2.2 child hc

Every child position of a same-depth internal node is itself same-depth.

private lemma sameDepth_of_mem
    {ks : List Nat} {c0 child : BTree} {cs : List BTree}
    (hsd : SameDepth (node ks (c0 :: cs)))
    (hc : child ∈ c0 :: cs) :
    SameDepth child := by
  rcases List.mem_cons.mp hc with rfl | hcTail
  · exact sameDepth_head_sd hsd
  · exact sameDepth_tail_sd hsd child hcTail

Every child of a same-depth internal node has the head child's height.

private lemma heightOf_eq_head_of_mem
    {ks : List Nat} {c0 child : BTree} {cs : List BTree}
    (hsd : SameDepth (node ks (c0 :: cs)))
    (hc : child ∈ c0 :: cs) :
    heightOf child = heightOf c0 :=
  sameDepth_children_eq_height hsd child hc c0 (by simp)

Non-root minimum-key bound

Every non-root B-tree subtree contains enough key slots for its height. The augmented form avoids natural-number subtraction and is the induction theorem used by the root-level CLRS bound.


theorem nonRoot_totalKeys_add_one_lower_bound
    (t : Nat) (_ht : 2 ≤ t) {tr : BTree}
    (hcb : ChildBounded tr)
    (hocc : Occupancy t false tr)
    (hsd : SameDepth tr) :
    t ^ (heightOf tr + 1) ≤ totalKeys tr + 1 := by
  induction hsd with
  | leaf ks =>
      simp [Occupancy] at hocc
      simp [heightOf, totalKeys_node]
      omega
  | internal ks c0 cs hheights hsd0 hsdcs ih0 ihcs =>
      have hsdNode : SameDepth (node ks (c0 :: cs)) :=
        SameDepth.internal ks c0 cs hheights hsd0 hsdcs
      have hcount : t ≤ (c0 :: cs).length := by
        have hocc' := hocc
        simp [Occupancy] at hocc'
        rcases hocc' with ⟨_, _, ⟨hcount, _⟩, _, _⟩
        exact hcount
      let q := t ^ (heightOf c0 + 1)
      have hpoint :
          ∀ child ∈ c0 :: cs, q ≤ totalKeys child + 1 := by
        intro child hc
        rcases List.mem_cons.mp hc with rfl | hcTail
        · exact ih0
            (childBounded_of_mem hcb (by simp))
            (occupancy_false_of_mem hocc (by simp))
        · have hcMem : child ∈ c0 :: cs := by simp [hcTail]
          simpa [q, heightOf_eq_head_of_mem hsdNode hcMem] using
            (ihcs child hcTail
              (childBounded_of_mem hcb hcMem)
              (occupancy_false_of_mem hocc hcMem))
      have hsum :
          (c0 :: cs).length * q ≤
            ((c0 :: cs).map (fun child => totalKeys child + 1)).sum :=
        length_mul_le_sum_map (c0 :: cs) q
          (fun child => totalKeys child + 1) hpoint
      have hmul : t * q ≤ (c0 :: cs).length * q :=
        Nat.mul_le_mul_right q hcount
      rw [totalKeys_add_one_eq_sum_children hcb]
      calc
        t ^ (heightOf (node ks (c0 :: cs)) + 1) = t * q := by
          rw [heightOf_internal_of_sameDepth hsdNode]
          have hexponent :
              1 + heightOf c0 + 1 = (heightOf c0 + 1) + 1 := by
            omega
          rw [hexponent, Nat.pow_succ]
          exact Nat.mul_comm _ _
        _ ≤ (c0 :: cs).length * q := hmul
        _ ≤ ((c0 :: cs).map (fun child => totalKeys child + 1)).sum := hsum

Root minimum-key and logarithmic-height bounds

A well-formed root is either the legal empty tree or has the CLRS augmented minimum key count for its height.


theorem wellFormed_empty_or_totalKeys_add_one_lower_bound
    (t : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hwf : WellFormed t tr) :
    tr = node [] [] ∨
      2 * t ^ heightOf tr ≤ totalKeys tr + 1 := by
  rcases hwf with ⟨_hsorted, hcb, hocc, hsd⟩
  cases tr with
  | node ks children =>
      cases children with
      | nil =>
          by_cases hks : ks = []
          · left
            simp [hks]
          · right
            simp [Occupancy, hks] at hocc
            simp [heightOf, totalKeys_node]
            omega
      | cons c0 cs =>
          right
          have hcount : 2 ≤ (c0 :: cs).length := by
            have hocc' := hocc
            unfold Occupancy at hocc'
            rcases hocc' with ⟨_, _, hchildren, _⟩
            rcases hchildren with hchildrenEmpty | hchildrenBounds
            · simp at hchildrenEmpty
            · exact hchildrenBounds.1
          let q := t ^ (heightOf c0 + 1)
          have hpoint :
              ∀ child ∈ c0 :: cs, q ≤ totalKeys child + 1 := by
            intro child hc
            simpa [q, heightOf_eq_head_of_mem hsd hc] using
              (nonRoot_totalKeys_add_one_lower_bound t ht
                (childBounded_of_mem hcb hc)
                (occupancy_false_of_mem hocc hc)
                (sameDepth_of_mem hsd hc))
          have hsum :
              (c0 :: cs).length * q ≤
                ((c0 :: cs).map (fun child => totalKeys child + 1)).sum :=
            length_mul_le_sum_map (c0 :: cs) q
              (fun child => totalKeys child + 1) hpoint
          have hmul : 2 * q ≤ (c0 :: cs).length * q :=
            Nat.mul_le_mul_right q hcount
          rw [totalKeys_add_one_eq_sum_children hcb]
          calc
            2 * t ^ heightOf (node ks (c0 :: cs)) = 2 * q := by
              rw [heightOf_internal_of_sameDepth hsd]
              simp [q, Nat.add_comm]
            _ ≤ (c0 :: cs).length * q := hmul
            _ ≤ ((c0 :: cs).map (fun child => totalKeys child + 1)).sum := hsum

A well-formed tree is empty or satisfies the textbook minimum-key expression.

theorem wellFormed_empty_or_minKeys_le_totalKeys
    (t : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hwf : WellFormed t tr) :
    tr = node [] [] ∨ minKeys t (heightOf tr) ≤ totalKeys tr := by
  rcases wellFormed_empty_or_totalKeys_add_one_lower_bound t ht hwf with
    hempty | hbound
  · exact Or.inl hempty
  · right
    unfold minKeys
    omega

Every nonempty well-formed tree satisfies the textbook minimum-key bound.

theorem wellFormed_minKeys_le_totalKeys
    (t : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hwf : WellFormed t tr)
    (hne : tr ≠ node [] []) :
    minKeys t (heightOf tr) ≤ totalKeys tr := by
  rcases wellFormed_empty_or_minKeys_le_totalKeys t ht hwf with
    hempty | hbound
  · exact (hne hempty).elim
  · exact hbound

The height of every well-formed B-tree, including the empty tree, is at most the minimum-degree-base logarithm of its CLRS normalized key count.


theorem wellFormed_height_log_bound
    (t : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hwf : WellFormed t tr) :
    heightOf tr ≤ Nat.log t ((totalKeys tr + 1) / 2) := by
  rcases wellFormed_empty_or_totalKeys_add_one_lower_bound t ht hwf with
    hempty | hbound
  · subst tr
    simp [heightOf, totalKeys, keysOf]
  · have htBase : 1 < t := by omega
    apply Nat.le_log_of_pow_le htBase
    have htwo : 0 < 2 := by omega
    apply (Nat.le_div_iff_mul_le htwo).2
    simpa [Nat.mul_comm] using hbound

              end BTreeend Chapter18end CLRS

CLRSLean.FourthEdition.Chapter_18.Section_18_1_B_Tree_Model.RunningTime

CLRS Chapter 18 - B-tree running time

This module bounds recursive-descent charges that follow the branch structure of the B-tree search, insertion, and deletion definitions. Each selected recursive call contributes one unit; terminal cases also contribute one. Top-level insertion adds one budget unit when the root splits.

These counters do not enumerate literal page reads/writes. In particular, split/borrow/merge accesses, separator scans, max/min predecessor/successor traversals, persistent list copying, and root-normalization work are not charged individually. No constant-factor refinement to complete page I/O is proved here.

Main results:

searchCost_le_height, insertCost_le_height, and deleteCost_le_height: the selected recursive path has at most height + 1 charges.
insertRootCost_le_height: the insertion descent/root-split budget is at most height + 3.
The historical *_le_diskAccessBound theorems bound these same descent counters on well-formed trees with 2 ≤ t.
diskAccessBound_isBigO_log_t: the common mathematical envelope is O(log_t n). The historical name is retained for compatibility; it does not convert the descent counter into a complete disk-access trace.

Functional insertion/deletion structure, key-bag, and search correctness are independent of this accounting boundary and remain available unchanged.

Notation conventions used in this section:

t : B-tree minimum degree (2 ≤ t for every cost theorem)
tr : a BTree
totalKeys tr : the number of represented key slots (the n of CLRS)

              namespace CLRSnamespace Chapter18namespace BTreeopen List

Recursive-descent charges

Number of nodes visited by searchExec for key x: one per level on the separator-selected descent path.

def searchCost (x : Nat) : BTree → Nat
  | node ks cs =>
      if x ∈ ks then 1
      else
        match _hc : cs[findChild ks x]? with
        | some child => 1 + searchCost x child
        | none => 1
termination_by tr => heightOf tr
decreasing_by
  exact heightOf_mem_lt (List.mem_iff_getElem?.mpr ⟨findChild ks x, _hc⟩)

Recursive-descent charges for the insertion branch structure. A full-child split changes the selected subtree but adds no separate page-read/write events. This is not a literal count of every node inspected or modified.

def insertCost (t x : Nat) : BTree → Nat
  | node ks cs =>
    if cs.isEmpty then 1
    else
      let i := findChild ks x
      match _hc : cs[i]? with
      | none => 1
      | some c =>
        match _hcc : c with
        | node cKeys cChildren =>
          if cKeys.length = 2 * t - 1 then
            let median := cKeys.getD (t - 1) 0
            if x < median then
              1 + insertCost t x (node (cKeys.take (t - 1)) (cChildren.take t))
            else
              1 + insertCost t x (node (cKeys.drop t) (cChildren.drop t))
          else
            1 + insertCost t x c
termination_by tr => heightOf tr
decreasing_by
  all_goals
    have hmem : node cKeys cChildren ∈ cs := List.mem_iff_getElem?.mpr ⟨i, _hc⟩
    refine lt_of_le_of_lt ?_ (heightOf_mem_lt hmem)
    first
      | exact le_of_eq (congrArg heightOf _hcc)
      | exact heightOf_le_of_children_subset (List.take_subset _ _)
      | exact heightOf_le_of_children_subset (List.drop_subset _ _)

Recursive-descent charges for deletion. Borrow/merge selects the next subtree; max/min chooses a replacement key. The helper traversals and local page operations are not counted by the added unit at each recursive level.


def deleteCost (t : Nat) (x : Nat) : BTree → Nat
  | node ks cs =>
    if cs.isEmpty then 1
    else
      let i := findChild ks x
      if Variable name `hiPos` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hiPos : 0 < i then
        let ki := i - 1
        match Variable name `hk` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hk : ks[ki]? with
        | some k =>
          if Variable name `hkeq` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hkeq : k = x then
            match Variable name `hcl` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hcl : cs[ki]? with
            | some leftChild =>
              match hcr : cs[ki + 1]? with
              | some rightChild =>
                if hla : t ≤ numKeys leftChild then
                  1 + deleteCost t (maxKey leftChild) leftChild
                else if hlb : t ≤ numKeys rightChild then
                  1 + deleteCost t (minKey rightChild) rightChild
                else
                  1 + deleteCost t x (mergeNodes leftChild k rightChild)
              | none => 1
            | none => 1
          else
            match Variable name `hc` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hc : cs[i]? with
            | some child =>
              if hcg : t ≤ numKeys child then
                1 + deleteCost t x child
              else
                match hls : cs[i - 1]? with
                | some leftSib =>
                  if Variable name `hlg` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hlg : t ≤ numKeys leftSib then
                    match hsep : ks[i - 1]? with
                    | some sep =>
                      1 + deleteCost t x (rotateLeft leftSib sep child).2.2
                    | none => 1 + deleteCost t x child
                  else
                    match Variable name `hrs` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hrs : cs[i + 1]? with
                    | some rightSib =>
                      if Variable name `hrg` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hrg : t ≤ numKeys rightSib then
                        match hsep : ks[i]? with
                        | some sep =>
                          1 + deleteCost t x (rotateRight child sep rightSib).1
                        | none => 1 + deleteCost t x child
                      else
                        match hsep : ks[i - 1]? with
                        | some sep =>
                          1 + deleteCost t x (mergeNodes leftSib sep child)
                        | none => 1 + deleteCost t x child
                    | none =>
                      match hsep : ks[i - 1]? with
                      | some sep =>
                        1 + deleteCost t x (mergeNodes leftSib sep child)
                      | none => 1 + deleteCost t x child
                | none => 1 + deleteCost t x child
            | none => 1
        | none =>
          match Variable name `hc` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hc : cs[i]? with
          | some child =>
            if hcg : t ≤ numKeys child then
              1 + deleteCost t x child
            else
              match hls : cs[i - 1]? with
              | some leftSib =>
                if Variable name `hlg` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hlg : t ≤ numKeys leftSib then
                  match hsep : ks[i - 1]? with
                  | some sep =>
                    1 + deleteCost t x (rotateLeft leftSib sep child).2.2
                  | none => 1 + deleteCost t x child
                else
                  match Variable name `hrs` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hrs : cs[i + 1]? with
                  | some rightSib =>
                    if Variable name `hrg` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hrg : t ≤ numKeys rightSib then
                      match hsep : ks[i]? with
                      | some sep =>
                        1 + deleteCost t x (rotateRight child sep rightSib).1
                      | none => 1 + deleteCost t x child
                    else
                      match hsep : ks[i - 1]? with
                      | some sep =>
                        1 + deleteCost t x (mergeNodes leftSib sep child)
                      | none => 1 + deleteCost t x child
                  | none =>
                    match hsep : ks[i - 1]? with
                    | some sep =>
                      1 + deleteCost t x (mergeNodes leftSib sep child)
                    | none => 1 + deleteCost t x child
              | none => 1 + deleteCost t x child
          | none => 1
      else
        match Variable name `hc` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hc : cs[0]? with
        | some child =>
          if hcg : t ≤ numKeys child then
            1 + deleteCost t x child
          else
            match hrs : cs[1]? with
            | some rightSib =>
              if Variable name `hrg` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hrg : t ≤ numKeys rightSib then
                match hsep : ks[0]? with
                | some sep =>
                  1 + deleteCost t x (rotateRight child sep rightSib).1
                | none => 1 + deleteCost t x child
              else
                match hsep : ks[0]? with
                | some sep =>
                  1 + deleteCost t x (mergeNodes child sep rightSib)
                | none => 1 + deleteCost t x child
            | none => 1 + deleteCost t x child
        | none => 1
termination_by tr => heightOf tr
decreasing_by
  · exact heightOf_mem_lt (List.mem_iff_getElem?.mpr ⟨ki, hcl⟩)
  · exact heightOf_mem_lt (List.mem_iff_getElem?.mpr ⟨ki + 1, hcr⟩)
  · 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
      | (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))
      | exact heightOf_mem_lt (List.mem_iff_getElem?.mpr ⟨_, hc⟩)
      | (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)
      | (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)

Height bounds

O(h) search. searchExec descends at most one path, so its number of descent charges is bounded by the tree height plus one.


theorem searchCost_le_height (x : Nat) (tr : BTree) :
    searchCost x tr ≤ heightOf tr + 1 := by
  induction tr using searchCost.induct x with
  | case1 ks cs hxkeys =>
      rw [searchCost, if_pos hxkeys]
      omega
  | case2 ks cs hxkeys child hchild ih =>
      rw [searchCost, if_neg hxkeys]
      split
      · rename_i child' hchild'
        rw [hchild] at hchild'
        cases hchild'
        have hlt : heightOf child < heightOf (node ks cs) :=
          heightOf_mem_lt (List.mem_iff_getElem?.mpr ⟨findChild ks x, hchild⟩)
        omega
      · rename_i hnone
        rw [hchild] at hnone
        contradiction
  | case3 ks cs hxkeys hchild =>
      rw [searchCost, if_neg hxkeys]
      split
      · rename_i child hchild'
        rw [hchild] at hchild'
        contradiction
      · omega

O(h) insertion. insertNonFull descends at most one path, so its number of descent charges is bounded by the tree height plus one.


theorem insertCost_le_height (t x : Nat) (tr : BTree) :
    insertCost t x tr ≤ heightOf tr + 1 := by
  induction tr using insertCost.induct (t := t) (x := x) with
  | case1 ks cs hempty =>
      rw [insertCost, if_pos hempty]
      omega
  | case2 ks cs hne i hnone =>
      have hval : insertCost t x (node ks cs) = 1 := by
        rw [insertCost, if_neg hne]
        dsimp only
        split
        · omega
        · rename_i c hc
          rw [hnone] at hc
          simp at hc
      rw [hval]
      omega
  | case3 ks cs hne i cKeys cChildren hsome hfull median hlt hsome2 ih =>
      have hsome' : cs[findChild ks x]? = some (node cKeys cChildren) := hsome
      have hval : insertCost t x (node ks cs)
          = 1 + insertCost t x (node (cKeys.take (t - 1)) (cChildren.take t)) := by
        rw [insertCost, if_neg hne]
        dsimp only
        split
        · rename_i hcnone
          rw [hsome'] at hcnone
          simp at hcnone
        · rename_i c hcsome
          obtain rfl : c = node cKeys cChildren := by
            rw [hsome'] at hcsome; injection hcsome with h; exact h.symm
          dsimp only
          rw [if_pos hfull, if_pos hlt]
      rw [hval]
      have hmem : node cKeys cChildren ∈ cs :=
        List.mem_iff_getElem?.mpr ⟨findChild ks x, hsome'⟩
      have hltH : heightOf (node (cKeys.take (t - 1)) (cChildren.take t)) <
          heightOf (node ks cs) :=
        lt_of_le_of_lt (heightOf_le_of_children_subset (List.take_subset _ _))
          (heightOf_mem_lt hmem)
      omega
  | case4 ks cs hne i cKeys cChildren hsome hfull median hnlt hsome2 ih =>
      have hsome' : cs[findChild ks x]? = some (node cKeys cChildren) := hsome
      have hval : insertCost t x (node ks cs)
          = 1 + insertCost t x (node (cKeys.drop t) (cChildren.drop t)) := by
        rw [insertCost, if_neg hne]
        dsimp only
        split
        · rename_i hcnone
          rw [hsome'] at hcnone
          simp at hcnone
        · rename_i c hcsome
          obtain rfl : c = node cKeys cChildren := by
            rw [hsome'] at hcsome; injection hcsome with h; exact h.symm
          dsimp only
          rw [if_pos hfull, if_neg hnlt]
      rw [hval]
      have hmem : node cKeys cChildren ∈ cs :=
        List.mem_iff_getElem?.mpr ⟨findChild ks x, hsome'⟩
      have hltH : heightOf (node (cKeys.drop t) (cChildren.drop t)) <
          heightOf (node ks cs) :=
        lt_of_le_of_lt (heightOf_le_of_children_subset (List.drop_subset _ _))
          (heightOf_mem_lt hmem)
      omega
  | case5 ks cs hne i cKeys cChildren hsome hnfull hsome2 ih =>
      have hsome' : cs[findChild ks x]? = some (node cKeys cChildren) := hsome
      have hval : insertCost t x (node ks cs)
          = 1 + insertCost t x (node cKeys cChildren) := by
        rw [insertCost, if_neg hne]
        dsimp only
        split
        · rename_i hcnone
          rw [hsome'] at hcnone
          simp at hcnone
        · rename_i c hcsome
          obtain rfl : c = node cKeys cChildren := by
            rw [hsome'] at hcsome; injection hcsome with h; exact h.symm
          dsimp only
          rw [if_neg hnfull]
      rw [hval]
      have hmem : node cKeys cChildren ∈ cs :=
        List.mem_iff_getElem?.mpr ⟨findChild ks x, hsome'⟩
      have hltH : heightOf (node cKeys cChildren) < heightOf (node ks cs) :=
        heightOf_mem_lt hmem
      omega

Deletion height bound

              private lemma child_lt_node (ks : List Nat) {cs : List BTree} {j : Nat} {c : BTree}
    (hc : cs[j]? = some c) : heightOf c < heightOf (node ks cs) :=
  heightOf_mem_lt (List.mem_iff_getElem?.mpr ⟨j, hc⟩)

private lemma merge_lt_node (ks : List Nat) {cs : List BTree} {a b : BTree} (s : Nat)
    (ha : a ∈ cs) (hb : b ∈ cs) :
    heightOf (mergeNodes a s b) < heightOf (node ks cs) := by
  rw [heightOf_mergeNodes_eq_max]
  have hha : heightOf a < heightOf (node ks cs) := heightOf_mem_lt ha
  have hhb : heightOf b < heightOf (node ks cs) := heightOf_mem_lt hb
  omegaprivate lemma rotateLeft_target_lt_node (ks : List Nat) {cs : List BTree} {a b : BTree} (s : Nat)
    (ha : a ∈ cs) (hb : b ∈ cs) :
    heightOf (rotateLeft a s b).2.2 < heightOf (node ks cs) := by
  have hle : heightOf (rotateLeft a s b).2.2 ≤ max (heightOf a) (heightOf b) :=
    heightOf_rotateLeft_right_le a s b
  have hha : heightOf a < heightOf (node ks cs) := heightOf_mem_lt ha
  have hhb : heightOf b < heightOf (node ks cs) := heightOf_mem_lt hb
  omegaprivate lemma rotateRight_target_lt_node (ks : List Nat) {cs : List BTree} {a b : BTree} (s : Nat)
    (ha : a ∈ cs) (hb : b ∈ cs) :
    heightOf (rotateRight a s b).1 < heightOf (node ks cs) := by
  have hle : heightOf (rotateRight a s b).1 ≤ max (heightOf a) (heightOf b) :=
    heightOf_rotateRight_left_le a s b
  have hha : heightOf a < heightOf (node ks cs) := heightOf_mem_lt ha
  have hhb : heightOf b < heightOf (node ks cs) := heightOf_mem_lt hb
  omega

O(h) deletion. composedDelete descends at most one path, so its number of descent charges is bounded by the tree height plus one.


theorem deleteCost_le_height (t x : Nat) (tr : BTree) :
    deleteCost t x tr ≤ heightOf tr + 1 := by
  induction x, tr using deleteCost.induct (t := t) with
  | case1 x ks cs hleaf =>
      rw [deleteCost, if_pos hleaf]
      omega
  | case2 ks cs hnonempty sep leftChild rightChild hleftReady i hpos ki hsep hleft hright ih =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hpos
      simp only [ki, i] at hsep hleft hright
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
      rw [hsep, hleft, hright]
      simp [hleftReady]
      have hlt := child_lt_node ks hleft
      omega
  | case3 ks cs hnonempty sep leftChild rightChild hleftNotReady hrightReady i hpos ki hsep hleft hright ih =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hpos
      simp only [ki, i] at hsep hleft hright
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
      rw [hsep, hleft, hright]
      simp [hleftNotReady, hrightReady]
      have hlt := child_lt_node ks hright
      omega
  | case4 ks cs hnonempty sep leftChild rightChild hleftNotReady hrightNotReady i hpos ki hsep hleft hright ih =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hpos
      simp only [ki, i] at hsep hleft hright
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
      rw [hsep, hleft, hright]
      simp [hleftNotReady, hrightNotReady]
      have hlt := merge_lt_node ks sep (List.mem_iff_getElem?.mpr ⟨ki, hleft⟩)
        (List.mem_iff_getElem?.mpr ⟨ki + 1, hright⟩)
      omega
  | case5 ks cs hnonempty sep leftChild i hpos ki hsep hleft hrightNone =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hpos
      simp only [ki, i] at hsep hleft hrightNone
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
      rw [hsep, hleft, hrightNone]
      simp
  | case6 ks cs hnonempty sep i hpos ki hsep hleftNone =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hpos
      simp only [ki, i] at hsep hleftNone
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
      rw [hsep, hleftNone]
      simp
  | case7 x ks cs hnonempty i hpos ki sep hsep hne child hchild hchildReady ih =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hpos
      simp only [ki, i] at hsep hchild
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
      rw [hsep, hchild]
      simp [hne, hchildReady]
      have hlt := child_lt_node ks hchild
      omega
  | case8 x ks cs hnonempty i hpos ki sep hsep hne child hchild hchildNotReady leftSib hleftSib hleftSibReady sep2 hsep2 ih =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hpos hchild hleftSib hsep2
      simp only [ki, i] at hsep
      have hsepEq : sep = sep2 := Option.some.inj (hsep.symm.trans hsep2)
      subst sep2
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
      rw [hsep, hchild, hleftSib]
      simp [hne, hchildNotReady, hleftSibReady]
      have hlt := rotateLeft_target_lt_node ks sep (List.mem_iff_getElem?.mpr ⟨i - 1, hleftSib⟩)
        (List.mem_iff_getElem?.mpr ⟨i, hchild⟩)
      omega
  | case9 x ks cs hnonempty i hpos ki sep hsep hne child hchild hchildNotReady leftSib hleftSib hleftSibReady hsepNone ih =>
      simp only [ki, i] at hsep hsepNone
      rw [hsep] at hsepNone
      cases hsepNone
  | case10 x ks cs hnonempty i hpos ki sep hsep hne child hchild hchildNotReady leftSib hleftSib hleftSibNotReady rightSib hrightSib hrightSibReady sep2 hsep2 ih =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hpos hchild hleftSib hrightSib hsep2
      simp only [ki, i] at hsep
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
      rw [hsep, hchild, hleftSib, hrightSib, hsep2]
      simp [hne, hchildNotReady, hleftSibNotReady, hrightSibReady]
      have hlt := rotateRight_target_lt_node ks sep2 (List.mem_iff_getElem?.mpr ⟨i, hchild⟩)
        (List.mem_iff_getElem?.mpr ⟨i + 1, hrightSib⟩)
      omega
  | case11 x ks cs hnonempty i hpos ki sep hsep hne child hchild hchildNotReady leftSib hleftSib hleftSibNotReady rightSib hrightSib hrightSibReady hsepNone ih =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hpos hchild hleftSib hrightSib hsepNone
      simp only [ki, i] at hsep
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
      rw [hsep, hchild, hleftSib, hrightSib, hsepNone]
      simp [hne, hchildNotReady, hleftSibNotReady, hrightSibReady]
      have hlt := child_lt_node ks hchild
      omega
  | case12 x ks cs hnonempty i hpos ki sep hsep hne child hchild hchildNotReady leftSib hleftSib hleftSibNotReady rightSib hrightSib hrightSibNotReady sep2 hsep2 ih =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hpos hchild hleftSib hrightSib hsep2
      simp only [ki, i] at hsep
      have hsepEq : sep = sep2 := Option.some.inj (hsep.symm.trans hsep2)
      subst sep2
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
      rw [hsep, hchild, hleftSib, hrightSib]
      simp [hne, hchildNotReady, hleftSibNotReady, hrightSibNotReady]
      have hlt := merge_lt_node ks sep (List.mem_iff_getElem?.mpr ⟨i - 1, hleftSib⟩)
        (List.mem_iff_getElem?.mpr ⟨i, hchild⟩)
      omega
  | case13 x ks cs hnonempty i hpos ki sep hsep hne child hchild hchildNotReady leftSib hleftSib hleftSibNotReady rightSib hrightSib hrightSibNotReady hsepNone ih =>
      simp only [ki, i] at hsep hsepNone
      rw [hsep] at hsepNone
      cases hsepNone
  | case14 x ks cs hnonempty i hpos ki sep hsep hne child hchild hchildNotReady leftSib hleftSib hleftSibNotReady hrightNone sep2 hsep2 ih =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hpos hchild hleftSib hrightNone hsep2
      simp only [ki, i] at hsep
      have hsepEq : sep = sep2 := Option.some.inj (hsep.symm.trans hsep2)
      subst sep2
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
      rw [hsep, hchild, hleftSib, hrightNone]
      simp [hne, hchildNotReady, hleftSibNotReady]
      have hlt := merge_lt_node ks sep (List.mem_iff_getElem?.mpr ⟨i - 1, hleftSib⟩)
        (List.mem_iff_getElem?.mpr ⟨i, hchild⟩)
      omega
  | case15 x ks cs hnonempty i hpos ki sep hsep hne child hchild hchildNotReady leftSib hleftSib hleftSibNotReady hrightNone hsepNone ih =>
      simp only [ki, i] at hsep hsepNone
      rw [hsep] at hsepNone
      cases hsepNone
  | case16 x ks cs hnonempty i hpos ki sep hsep hne child hchild hchildNotReady hleftNone ih =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hpos
      simp only [ki, i] at hsep hchild hleftNone
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
      rw [hsep, hchild, hleftNone]
      simp [hne, hchildNotReady]
      have hlt := child_lt_node ks hchild
      omega
  | case17 x ks cs hnonempty i hpos ki sep hsep hne hchildNone =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hpos
      simp only [ki, i] at hsep hchildNone
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
      rw [hsep, hchildNone]
      simp [hne]
  | case18 x ks cs hnonempty i hpos ki hsepNone child hchild hchildReady ih =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hpos
      simp only [ki, i] at hsepNone hchild
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
      rw [hsepNone, hchild]
      simp [hchildReady]
      have hlt := child_lt_node ks hchild
      omega
  | case19 x ks cs hnonempty i hpos ki hsepNone child hchild hchildNotReady leftSib hleftSib hleftSibReady sep hsep ih =>
      simp only [i] at hsep
      simp only [ki, i] at hsepNone
      rw [hsepNone] at hsep
      cases hsep
  | case20 x ks cs hnonempty i hpos ki hsepNone child hchild hchildNotReady leftSib hleftSib hleftSibReady hsepNone2 ih =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hpos hchild hleftSib
      simp only [ki, i] at hsepNone
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
      rw [hsepNone, hchild, hleftSib]
      simp [hchildNotReady, hleftSibReady]
      have hlt := child_lt_node ks hchild
      omega
  | case21 x ks cs hnonempty i hpos ki hsepNone child hchild hchildNotReady leftSib hleftSib hleftSibNotReady rightSib hrightSib hrightSibReady sep hsep ih =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hpos hchild hleftSib hrightSib hsep
      simp only [ki, i] at hsepNone
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
      rw [hsepNone, hchild, hleftSib, hrightSib, hsep]
      simp [hchildNotReady, hleftSibNotReady, hrightSibReady]
      have hlt := rotateRight_target_lt_node ks sep (List.mem_iff_getElem?.mpr ⟨i, hchild⟩)
        (List.mem_iff_getElem?.mpr ⟨i + 1, hrightSib⟩)
      omega
  | case22 x ks cs hnonempty i hpos ki hsepNone child hchild hchildNotReady leftSib hleftSib hleftSibNotReady rightSib hrightSib hrightSibReady hsepNone2 ih =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hpos hchild hleftSib hrightSib hsepNone2
      simp only [ki, i] at hsepNone
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
      rw [hsepNone, hchild, hleftSib, hrightSib, hsepNone2]
      simp [hchildNotReady, hleftSibNotReady, hrightSibReady]
      have hlt := child_lt_node ks hchild
      omega
  | case23 x ks cs hnonempty i hpos ki hsepNone child hchild hchildNotReady leftSib hleftSib hleftSibNotReady rightSib hrightSib hrightSibNotReady sep hsep ih =>
      simp only [i] at hsep
      simp only [ki, i] at hsepNone
      rw [hsepNone] at hsep
      cases hsep
  | case24 x ks cs hnonempty i hpos ki hsepNone child hchild hchildNotReady leftSib hleftSib hleftSibNotReady rightSib hrightSib hrightSibNotReady hsepNone2 ih =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hpos hchild hleftSib hrightSib
      simp only [ki, i] at hsepNone
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
      rw [hsepNone, hchild, hleftSib, hrightSib]
      simp [hchildNotReady, hleftSibNotReady, hrightSibNotReady]
      have hlt := child_lt_node ks hchild
      omega
  | case25 x ks cs hnonempty i hpos ki hsepNone child hchild hchildNotReady leftSib hleftSib hleftSibNotReady hrightNone sep hsep ih =>
      simp only [i] at hsep
      simp only [ki, i] at hsepNone
      rw [hsepNone] at hsep
      cases hsep
  | case26 x ks cs hnonempty i hpos ki hsepNone child hchild hchildNotReady leftSib hleftSib hleftSibNotReady hrightNone hsepNone2 ih =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hpos hchild hleftSib hrightNone
      simp only [ki, i] at hsepNone
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
      rw [hsepNone, hchild, hleftSib, hrightNone]
      simp [hchildNotReady, hleftSibNotReady]
      have hlt := child_lt_node ks hchild
      omega
  | case27 x ks cs hnonempty i hpos ki hsepNone child hchild hchildNotReady hleftNone ih =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hpos hchild hleftNone
      simp only [ki, i] at hsepNone
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
      rw [hsepNone, hchild, hleftNone]
      simp [hchildNotReady]
      have hlt := child_lt_node ks hchild
      omega
  | case28 x ks cs hnonempty i hpos ki hsepNone hchildNone =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hpos
      simp only [ki, i] at hsepNone hchildNone
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte, hpos]
      rw [hsepNone, hchildNone]
      simp
  | case29 x ks cs hnonempty i hnotPos child hchild hchildReady ih =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hnotPos
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte]
      rw [dif_neg hnotPos]
      rw [hchild]
      simp [hchildReady]
      have hlt := child_lt_node ks hchild
      omega
  | case30 x ks cs hnonempty i hnotPos child hchild hchildNotReady rightSib hrightSib hrightSibReady sep hsep ih =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hnotPos
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte]
      rw [dif_neg hnotPos]
      rw [hchild, hrightSib, hsep]
      simp [hchildNotReady, hrightSibReady]
      have hlt := rotateRight_target_lt_node ks sep (List.mem_iff_getElem?.mpr ⟨0, hchild⟩)
        (List.mem_iff_getElem?.mpr ⟨1, hrightSib⟩)
      omega
  | case31 x ks cs hnonempty i hnotPos child hchild hchildNotReady rightSib hrightSib hrightSibReady hsepNone ih =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hnotPos
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte]
      rw [dif_neg hnotPos]
      rw [hchild, hrightSib, hsepNone]
      simp [hchildNotReady, hrightSibReady]
      have hlt := child_lt_node ks hchild
      omega
  | case32 x ks cs hnonempty i hnotPos child hchild hchildNotReady rightSib hrightSib hrightSibNotReady sep hsep ih =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hnotPos
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte]
      rw [dif_neg hnotPos]
      rw [hchild, hrightSib, hsep]
      simp [hchildNotReady, hrightSibNotReady]
      have hlt := merge_lt_node ks sep (List.mem_iff_getElem?.mpr ⟨0, hchild⟩)
        (List.mem_iff_getElem?.mpr ⟨1, hrightSib⟩)
      omega
  | case33 x ks cs hnonempty i hnotPos child hchild hchildNotReady rightSib hrightSib hrightSibNotReady hsepNone ih =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hnotPos
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte]
      rw [dif_neg hnotPos]
      rw [hchild, hrightSib, hsepNone]
      simp [hchildNotReady, hrightSibNotReady]
      have hlt := child_lt_node ks hchild
      omega
  | case34 x ks cs hnonempty i hnotPos child hchild hchildNotReady hrightNone ih =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hnotPos
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte]
      rw [dif_neg hnotPos]
      rw [hchild, hrightNone]
      simp [hchildNotReady]
      have hlt := child_lt_node ks hchild
      omega
  | case35 x ks cs hnonempty i hnotPos hchildNone =>
      have hnotLeaf : cs.isEmpty = false := Bool.eq_false_of_not_eq_true hnonempty
      simp only [i] at hnotPos
      rw [deleteCost]
      simp only [hnotLeaf, Bool.false_eq_true, ↓reduceIte]
      rw [dif_neg hnotPos]
      rw [hchildNone]
      simp

Top-level insertion cost

Insertion descent budget with one extra charge for the full-root split. The charge is a budget unit, not a literal count of split-page reads/writes.

def insertRootCost (t x : Nat) (tr : BTree) : Nat :=
  if rootKeyCount tr = 2 * t - 1 then insertCost t x (splitRoot t tr) + 1
  else insertCost t x tr

O(h) top-level insertion. Splitting a full root adds exactly one level and then insertNonFull descends at most one path, so the cost is bounded by the tree height plus three.


theorem insertRootCost_le_height (t x : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hwf : WellFormed t tr) :
    insertRootCost t x tr ≤ heightOf tr + 3 := by
  unfold insertRootCost
  by_cases hfull : rootKeyCount tr = 2 * t - 1
  · rw [if_pos hfull]
    have hsplit : heightOf (splitRoot t tr) = heightOf tr + 1 :=
      splitRoot_height t ht hwf hfull
    have hins := insertCost_le_height t x (splitRoot t tr)
    omega
  · rw [if_neg hfull]
    have hins := insertCost_le_height t x tr
    omega

Logarithmic descent-budget bounds

Common logarithmic envelope for the descent budgets. Its historical diskAccessBound name is retained, but a full page-I/O interpretation requires additional accounting not established in this module.

def diskAccessBound (t : Nat) (n : Nat) : Nat := Nat.log t ((n + 1) / 2) + 3

Search has at most log_t n + O(1) descent charges on a well-formed tree.

theorem searchCost_le_diskAccessBound (t : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hwf : WellFormed t tr) (x : Nat) :
    searchCost x tr ≤ diskAccessBound t (totalKeys tr) := by
  have hh : heightOf tr ≤ Nat.log t ((totalKeys tr + 1) / 2) :=
    wellFormed_height_log_bound t ht hwf
  have hc := searchCost_le_height x tr
  unfold diskAccessBound
  omega

Top-level insertion has at most log_t n + O(1) descent/root-split charges on a well-formed tree.

theorem insertRootCost_le_diskAccessBound (t : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hwf : WellFormed t tr) (x : Nat) :
    insertRootCost t x tr ≤ diskAccessBound t (totalKeys tr) := by
  have hh : heightOf tr ≤ Nat.log t ((totalKeys tr + 1) / 2) :=
    wellFormed_height_log_bound t ht hwf
  have hc := insertRootCost_le_height t x ht hwf
  unfold diskAccessBound
  omega

Deletion has at most log_t n + O(1) descent charges on a well-formed tree.

theorem deleteCost_le_diskAccessBound (t : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hwf : WellFormed t tr) (x : Nat) :
    deleteCost t x tr ≤ diskAccessBound t (totalKeys tr) := by
  have hh : heightOf tr ≤ Nat.log t ((totalKeys tr + 1) / 2) :=
    wellFormed_height_log_bound t ht hwf
  have hc := deleteCost_le_height t x tr
  unfold diskAccessBound
  omega

The common descent-budget envelope is O(log_t n). This is an asymptotic theorem about the displayed numeric bound, not an additional operational refinement for page I/O or auxiliary traversals.


theorem diskAccessBound_isBigO_log_t (t : Nat) (ht : 2 ≤ t) :
    CLRS.Chapter03.isBigO (fun n => (diskAccessBound t n : ℝ))
      (fun n => (Nat.log t n : ℝ)) := by
  rw [CLRS.Chapter03.isBigO_iff]
  refine ⟨4, by norm_num, t, ?_⟩
  intro n hn
  have hmono : Nat.log t ((n + 1) / 2) ≤ Nat.log t n := by
    apply Nat.log_mono_right
    omega
  have hlogpos : 0 < Nat.log t n := Nat.log_pos (by omega : 1 < t) (by omega : t ≤ n)
  unfold diskAccessBound
  have h1 : (Nat.log t ((n + 1) / 2) + 3 : ℝ) ≤ 4 * (Nat.log t n : ℝ) := by
    have h2 : (Nat.log t ((n + 1) / 2) : ℝ) ≤ (Nat.log t n : ℝ) := by
      exact_mod_cast hmono
    have h3 : (3 : ℝ) ≤ 3 * (Nat.log t n : ℝ) := by
      have h4 : (1 : ℝ) ≤ (Nat.log t n : ℝ) := by
        exact_mod_cast (Nat.succ_le_of_lt hlogpos)
      nlinarith
    nlinarith
  have h_nonneg_left : 0 ≤ ((Nat.log t ((n + 1) / 2) + 3 : Nat) : ℝ) := by positivity
  have h_nonneg_right : 0 ≤ (Nat.log t n : ℝ) := by positivity
  rw [abs_of_nonneg h_nonneg_left, abs_of_nonneg h_nonneg_right]
  push_cast
  exact h1

              end BTreeend Chapter18end CLRS

CLRSLean.FourthEdition.Chapter_18.Section_18_1_B_Tree_Model.Search

CLRS Section 18.1 - Separator-guided B-tree search

Defines the child-selection function used by B-tree search and insertion, reusable path-localization and height lemmas, and a total executable search that descends through exactly one separator-selected child.

Main results:

findChild_localizes_mem: localizes a non-separator member to the selected child under sorted and child-bounded node invariants.
searchExec: checks the current node and otherwise follows only the separator-selected child.
searchExec_sound: successful executable search implies membership without structural assumptions.
searchExec_complete: sorted, child-bounded trees expose every member along the selected path.
searchExec_true_iff: on sorted, child-bounded trees, characterizes successful executable search by membership.
searchExec_eq_search: on sorted, child-bounded trees, connects executable search to the imported specification oracle search.

The selected-child localization and routing wrappers are used by the proved exact erase-one semantics for executable deletion.

namespace CLRS.Chapter18.BTreeopen List

Child selection

Index of the child that key x descends into: the number of leading keys ≤ x (correct for a sorted key list).

def findChild : List Nat → Nat → Nat
  | [], _ => 0
  | k :: ks, x => if k ≤ x then findChild ks x + 1 else 0

Height lemmas

foldl max never drops below its accumulator.

lemma foldl_max_ge (b : Nat) (l : List Nat) : b ≤ l.foldl max b := by
  induction l generalizing b with
  | nil => simp
  | cons y ys ih =>
    simp only [List.foldl_cons]
    exact le_trans (le_max_left b y) (ih (max b y))

Every element of l is ≤ l.foldl max b.

lemma mem_le_foldl_max : ∀ {l : List Nat} {a b : Nat}, a ∈ l → a ≤ l.foldl max b := by
  intro l
  induction l with
  | nil => intro a b h; simp at h
  | cons y ys ih =>
    intro a b h
    simp only [List.foldl_cons]
    rcases List.mem_cons.mp h with rfl | h
    · exact le_trans (le_max_right b a) (foldl_max_ge (max b a) ys)
    · exact ih h

If every element of l is ≤ M and b ≤ M, then l.foldl max b ≤ M.

lemma foldl_max_le' : ∀ {l : List Nat} {M b : Nat}, b ≤ M → (∀ a ∈ l, a ≤ M) → l.foldl max b ≤ M := by
  intro l
  induction l with
  | nil => intro M b hb _; simpa using hb
  | cons y ys ih =>
    intro M b hb h
    simp only [List.foldl_cons]
    exact ih (max_le hb (h y (by simp))) (fun a ha => h a (by simp [ha]))

Folding max over the heights of a sub-multiset of children is ≤ folding over the full children list.


lemma foldl_max_heightOf_subset {cs' cs : List BTree} (h : cs' ⊆ cs) :
    (cs'.map heightOf).foldl max 0 ≤ (cs.map heightOf).foldl max 0 := by
  apply foldl_max_le' (foldl_max_ge 0 _)
  intro a ha
  rw [List.mem_map] at ha
  obtain ⟨c, hc, rfl⟩ := ha
  exact mem_le_foldl_max (List.mem_map_of_mem (h hc))

A child is strictly shorter than its parent.

lemma heightOf_mem_lt {ks : List Nat} {children : List BTree} {c : BTree}
    (hc : c ∈ children) : heightOf c < heightOf (node ks children) := by
  cases children with
  | nil => simp at hc
  | cons d ds =>
    have hle := mem_le_foldl_max (a := heightOf c) (b := 0) (List.mem_map_of_mem hc)
    simp only [heightOf]
    omega

Replacing the children of a node by a sub-multiset cannot increase the height.

lemma heightOf_le_of_children_subset {a b : List Nat} {cs' cs : List BTree}
    (h : cs' ⊆ cs) : heightOf (node a cs') ≤ heightOf (node b cs) := by
  cases cs' with
  | nil => simp [heightOf]
  | cons d ds =>
    cases cs with
    | nil => exact absurd (h List.mem_cons_self) (by simp)
    | cons e es =>
      have hsub := foldl_max_heightOf_subset (cs' := d :: ds) (cs := e :: es) h
      simp only [heightOf]
      omega

Child-index bounds and range correctness

findChild never exceeds the number of keys, so on a node with children.length = keys.length + 1 it always indexes a real child.

lemma findChild_le (ks : List Nat) (x : Nat) : findChild ks x ≤ ks.length := by
  induction ks with
  | nil => simp [findChild]
  | cons k ks ih =>
    unfold findChild
    split
    · simp only [List.length_cons]; omega
    · omega

Every key before the chosen child index is ≤ x.


lemma findChild_take_le (x : Nat) : ∀ (ks : List Nat), ∀ k ∈ ks.take (findChild ks x), k ≤ x := by
  intro ks
  induction ks with
  | nil => intro k hk; simp at hk
  | cons a as ih =>
    intro k hk
    rw [findChild] at hk
    split at hk
    · rename_i hax
      rw [List.take_succ_cons] at hk
      rcases List.mem_cons.mp hk with rfl | hk
      · exact hax
      · exact ih k hk
    · simp at hk

On a sorted key list, every key from the chosen child index onward is > x.


lemma findChild_drop_gt (x : Nat) : ∀ {ks : List Nat}, List.Pairwise (· ≤ ·) ks →
    ∀ k ∈ ks.drop (findChild ks x), x < k := by
  intro ks
  induction ks with
  | nil => intro _ k hk; simp at hk
  | cons a as ih =>
    intro hs k hk
    have hsa : ∀ b ∈ as, a ≤ b := (List.pairwise_cons.mp hs).1
    have hs' : List.Pairwise (· ≤ ·) as := (List.pairwise_cons.mp hs).2
    rw [findChild] at hk
    split at hk
    · rename_i hax
      rw [List.drop_succ_cons] at hk
      exact ih hs' k hk
    · rename_i hax
      have hxa : x < a := not_le.mp hax
      simp only [List.drop_zero, List.mem_cons] at hk
      rcases hk with rfl | hk
      · exact hxa
      · exact lt_of_lt_of_le hxa (hsa k hk)

The right separator at the chosen child bounds x from above (sorted keys).


lemma findChild_x_hi {ks : List Nat} (hs : List.Pairwise (· ≤ ·) ks) (x : Nat) :
    ∀ hi, ks[findChild ks x]? = some hi → x ≤ hi := by
  intro hi hhi
  have hmem : hi ∈ ks.drop (findChild ks x) := by
    rw [List.mem_iff_getElem?]
    exact ⟨0, by rw [List.getElem?_drop, Nat.add_zero]; exact hhi⟩
  exact le_of_lt (findChild_drop_gt x hs hi hmem)

The left separator at the chosen child bounds x from below.


lemma findChild_x_lo (ks : List Nat) (x : Nat) :
    findChild ks x = 0 ∨ ∀ lo, ks[findChild ks x - 1]? = some lo → lo ≤ x := by
  rcases Nat.eq_zero_or_pos (findChild ks x) with h0 | hpos
  · exact Or.inl h0
  · right
    intro lo hlo
    have hmem : lo ∈ ks.take (findChild ks x) := by
      rw [List.mem_iff_getElem?]
      exact ⟨findChild ks x - 1, by rw [List.getElem?_take_of_lt (by omega)]; exact hlo⟩
    exact findChild_take_le x ks lo hmem

If a key absent from a sorted node's separators occurs in one of its children, that child is exactly the one selected by findChild.


theorem findChild_localizes_mem
    {ks : List Nat} {cs : List BTree} {x j : Nat} {child : BTree}
    (hsorted : List.Pairwise (· ≤ ·) ks)
    (hbounded : ChildBounded (node ks cs))
    (hxkeys : x ∉ ks)
    (hchild : cs[j]? = some child)
    (hxchild : x ∈ keysOf child) :
    j = findChild ks x := by
  have hjcs : j < cs.length :=
    _root_.of_getElem?_eq_some (c := cs) (i := j) hchild
  have hchild_get : cs.get ⟨j, hjcs⟩ = child :=
    (_root_.getElem?_eq_some_iff.mp hchild).choose_spec
  unfold ChildBounded at hbounded
  rcases hbounded with ⟨hshape, hbounds, _⟩
  have hlength : cs.length = ks.length + 1 := by
    rcases hshape with hempty | hlength
    · have : cs.length = 0 := by simpa using hempty
      omega
    · exact hlength
  have hjbounds := hbounds j hjcs
  dsimp only at hjbounds
  rw [hchild_get] at hjbounds
  have hnot_left : ¬j < findChild ks x := by
    intro hjleft
    have hjks : j < ks.length := by
      have := findChild_le ks x
      omega
    have hsep_mem : ks[j] ∈ ks.take (findChild ks x) := by
      rw [List.mem_iff_getElem?]
      refine ⟨j, ?_⟩
      rw [List.getElem?_take_of_lt hjleft, List.getElem?_eq_getElem hjks]
    have hsep_le : ks[j] ≤ x :=
      findChild_take_le x ks ks[j] hsep_mem
    have hkey_le : x ≤ ks[j] := by
      have hupper := hjbounds.2
      simp only [List.getElem?_eq_getElem hjks] at hupper
      exact hupper x hxchild
    apply hxkeys
    rw [show x = ks[j] by omega]
    exact List.getElem_mem hjks
  have hnot_right : ¬findChild ks x < j := by
    intro hjright
    have hjpos : 0 < j := by omega
    have hjpred : j - 1 < ks.length := by omega
    have hsep_mem : ks[j - 1] ∈ ks.drop (findChild ks x) := by
      rw [List.mem_iff_getElem?]
      refine ⟨j - 1 - findChild ks x, ?_⟩
      rw [List.getElem?_drop]
      have hindex :
          findChild ks x + (j - 1 - findChild ks x) = j - 1 := by
        omega
      rw [hindex, List.getElem?_eq_getElem hjpred]
    have hx_lt : x < ks[j - 1] :=
      findChild_drop_gt x hsorted (ks[j - 1]) hsep_mem
    have hsep_le : ks[j - 1] ≤ x := by
      rcases hjbounds.1 with hjzero | hlower
      · omega
      · simp only [List.getElem?_eq_getElem hjpred] at hlower
        exact hlower x hxchild
    omega
  omega

If a key occurs among sorted separators, the selected child index is positive and its predecessor separator is that key.


theorem findChild_pos_and_pred_eq_of_mem
    {ks : List Nat} {x : Nat}
    (hsorted : List.Pairwise (· ≤ ·) ks)
    (hx : x ∈ ks) :
    0 < findChild ks x ∧
      ks[findChild ks x - 1]? = some x := by
  induction ks with
  | nil => simp at hx
  | cons a as ih =>
      have hsortedTail : List.Pairwise (· ≤ ·) as :=
        (List.pairwise_cons.mp hsorted).2
      have ha_le : a ≤ x := by
        rcases List.mem_cons.mp hx with hxa | hxTail
        · omega
        · exact (List.pairwise_cons.mp hsorted).1 x hxTail
      rw [findChild, if_pos ha_le]
      refine ⟨by omega, ?_⟩
      simp only [Nat.add_sub_cancel]
      by_cases hxTail : x ∈ as
      · obtain ⟨hpos, hpred⟩ := ih hsortedTail hxTail
        cases hfind : findChild as x with
        | zero => omega
        | succ j =>
            simp only [hfind, Nat.succ_sub_one] at hpred
            simpa [hfind] using hpred
      · have hxa : x = a :=
          (List.mem_cons.mp hx).resolve_right hxTail
        subst x
        have hzero : findChild as a = 0 := by
          cases as with
          | nil => rfl
          | cons b bs =>
              have hab : a ≤ b :=
                (List.pairwise_cons.mp hsorted).1 b (by simp)
              have hne : b ≠ a := by
                intro hba
                apply hxTail
                simp [hba]
              have hnot : ¬b ≤ a := by omega
              simp [findChild, hnot]
        simp [hzero]

A non-selected child of a sorted, child-bounded node cannot contain a key that is absent from the node's separators.

theorem findChild_not_mem_child_of_ne
    {ks : List Nat} {cs : List BTree} {x j : Nat} {child : BTree}
    (hsorted : List.Pairwise (· ≤ ·) ks)
    (hbounded : ChildBounded (node ks cs))
    (hxkeys : x ∉ ks)
    (hchild : cs[j]? = some child)
    (hne : j ≠ findChild ks x) :
    x ∉ keysOf child := by
  intro hxchild
  exact hne
    (findChild_localizes_mem hsorted hbounded hxkeys hchild hxchild)

If a non-separator key belongs to a sorted, child-bounded node, it belongs to the selected child.


theorem findChild_selected_child_mem
    {ks : List Nat} {cs : List BTree} {x : Nat} {child : BTree}
    (hsorted : List.Pairwise (· ≤ ·) ks)
    (hbounded : ChildBounded (node ks cs))
    (hxkeys : x ∉ ks)
    (hchild : cs[findChild ks x]? = some child)
    (hx : x ∈ keysOf (node ks cs)) :
    x ∈ keysOf child := by
  unfold keysOf at hx
  rw [List.mem_append, List.mem_flatMap] at hx
  rcases hx with hxnode | ⟨descendant, hdescendant, hxdescendant⟩
  · exact (hxkeys hxnode).elim
  · obtain ⟨j, hj⟩ := List.mem_iff_getElem?.mp hdescendant
    have hjfind : j = findChild ks x :=
      findChild_localizes_mem hsorted hbounded hxkeys hj hxdescendant
    rw [hjfind, hchild] at hj
    cases hj
    exact hxdescendant

Executable search

Separator-guided executable B-tree search. The current node is checked first; on a miss, search continues only in the child selected by findChild.

def searchExec (x : Nat) : BTree → Bool
  | node ks cs =>
      if x ∈ ks then
        true
      else
        match _hc : cs[findChild ks x]? with
        | some child => searchExec x child
        | none => false
termination_by tr => heightOf tr
decreasing_by
  exact heightOf_mem_lt (List.mem_iff_getElem?.mpr ⟨findChild ks x, _hc⟩)

Executable search is sound on every B-tree: a successful result witnesses membership in the tree, without requiring structural invariants.


theorem searchExec_sound {x : Nat} {tr : BTree}
    (hsearch : searchExec x tr = true) : mem x tr := by
  revert hsearch
  induction tr using searchExec.induct x with
  | case1 ks cs hxkeys =>
      intro _
      unfold mem keysOf
      exact List.mem_append_left _ hxkeys
  | case2 ks cs hxkeys child hchild ih =>
      intro hsearch
      have hchild_search : searchExec x child = true := by
        rw [searchExec, if_neg hxkeys] at hsearch
        split at hsearch
        · rename_i child' hchild'
          rw [hchild] at hchild'
          cases hchild'
          exact hsearch
        · rename_i hnone
          rw [hchild] at hnone
          contradiction
      have hchild_mem : x ∈ keysOf child := ih hchild_search
      unfold mem keysOf
      rw [List.mem_append, List.mem_flatMap]
      right
      exact ⟨child, List.mem_iff_getElem?.mpr ⟨findChild ks x, hchild⟩, hchild_mem⟩
  | case3 ks cs hxkeys hchild =>
      intro hsearch
      rw [searchExec, if_neg hxkeys] at hsearch
      split at hsearch
      · rename_i child hsome
        rw [hchild] at hsome
        contradiction
      · simp at hsearch

On sorted, child-bounded B-trees, executable search is complete: every member is found by the separator-selected descent path.


theorem searchExec_complete {x : Nat} {tr : BTree}
    (hsorted : Sorted tr) (hbounded : ChildBounded tr)
    (hmem : mem x tr) : searchExec x tr = true := by
  revert hsorted hbounded hmem
  induction tr using searchExec.induct x with
  | case1 ks cs hxkeys =>
      intro _ _ _
      rw [searchExec, if_pos hxkeys]
  | case2 ks cs hxkeys child hchild ih =>
      intro hsorted hbounded hmem
      unfold Sorted at hsorted
      rcases hsorted with ⟨hkeys_sorted, hchildren_sorted⟩
      unfold mem keysOf at hmem
      rw [List.mem_append, List.mem_flatMap] at hmem
      rcases hmem with hxnode | ⟨descendant, hdescendant, hxdescendant⟩
      · exact (hxkeys hxnode).elim
      · obtain ⟨j, hj⟩ := List.mem_iff_getElem?.mp hdescendant
        have hjfind : j = findChild ks x :=
          findChild_localizes_mem hkeys_sorted hbounded hxkeys hj hxdescendant
        subst j
        rw [hchild] at hj
        cases hj
        have hchild_mem : child ∈ cs :=
          List.mem_iff_getElem?.mpr ⟨findChild ks x, hchild⟩
        have hchild_sorted : Sorted child :=
          hchildren_sorted child hchild_mem
        have hchild_bounded : ChildBounded child := by
          unfold ChildBounded at hbounded
          exact hbounded.2.2 child hchild_mem
        have hchild_search : searchExec x child = true :=
          ih hchild_sorted hchild_bounded hxdescendant
        rw [searchExec, if_neg hxkeys]
        split
        · rename_i child' hchild'
          rw [hchild] at hchild'
          cases hchild'
          exact hchild_search
        · rename_i hnone
          rw [hchild] at hnone
          contradiction
  | case3 ks cs hxkeys hchild =>
      intro hsorted hbounded hmem
      unfold Sorted at hsorted
      rcases hsorted with ⟨hkeys_sorted, _⟩
      unfold mem keysOf at hmem
      rw [List.mem_append, List.mem_flatMap] at hmem
      rcases hmem with hxnode | ⟨descendant, hdescendant, hxdescendant⟩
      · exact (hxkeys hxnode).elim
      · obtain ⟨j, hj⟩ := List.mem_iff_getElem?.mp hdescendant
        have hjfind : j = findChild ks x :=
          findChild_localizes_mem hkeys_sorted hbounded hxkeys hj hxdescendant
        rw [hjfind, hchild] at hj
        contradiction

On sorted, child-bounded trees, executable search returns true exactly for members of the tree.

theorem searchExec_true_iff {x : Nat} {tr : BTree}
    (hsorted : Sorted tr) (hbounded : ChildBounded tr) :
    searchExec x tr = true ↔ mem x tr :=
  ⟨searchExec_sound, searchExec_complete hsorted hbounded⟩

On sorted, child-bounded trees, separator-guided executable search agrees with the specification-level membership oracle search.

theorem searchExec_eq_search {x : Nat} {tr : BTree}
    (hsorted : Sorted tr) (hbounded : ChildBounded tr) :
    searchExec x tr = search x tr := by
  apply Bool.eq_iff_iff.mpr
  exact (searchExec_true_iff hsorted hbounded).trans (search_true_iff x tr).symm

end CLRS.Chapter18.BTree

Imports

import CLRSLean.FourthEdition.Chapter_18.Section_18_1_B_Tree_Model.Search

18.2. B-Tree Insertion

This section retains the first-pass specification-level split and insertion wrappers over the mathematical B-tree model from Section 18.1, and proves the real functional B-TREE-INSERT-NONFULL and top-level B-TREE-INSERT algorithms against the full structural invariant.

Main results:

Theorem BTree.splitChild_preserves_model: the first-pass split wrapper preserves validity and membership.
Theorem BTree.splitChild_valid: the first-pass split wrapper preserves validity.
Theorem BTree.splitChild_mem_iff: membership after the first-pass split wrapper is unchanged.
Theorem BTree.splitChild_not_mem_iff: failed membership is also unchanged after the first-pass split wrapper.
Theorem BTree.splitChild_not_mem_old: old absent keys remain absent after the first-pass split wrapper.
Theorem BTree.splitChild_search_iff: searching after the first-pass split wrapper is equivalent to searching before it.
Theorem BTree.splitChild_search_false_iff: unsuccessful search is also preserved by the first-pass split wrapper.
Theorem BTree.splitChild_search_false_old: old unsuccessful searches remain unsuccessful after the first-pass split wrapper.
Theorems BTree.splitChild_mem_old and BTree.splitChild_search_old: old members and searchable keys remain so after the first-pass split wrapper.
Theorems BTree.splitChild_search_of_mem and BTree.splitChild_search_false_of_not_mem: old membership and absence give direct post-split successful and failed searches.
Theorem BTree.insert_preserves_model: specification insertion preserves the first-pass validity predicate.
Theorem BTree.insert_valid: direct validity-preservation wrapper for specification insertion.
Theorem BTree.insert_mem_iff: insertion adds exactly the inserted key to the membership specification.
Theorem BTree.insert_search_iff: searching after insertion succeeds exactly for the inserted key or an old searchable key.
Theorem BTree.insert_search_false_iff: searching after insertion fails exactly for keys different from the inserted key that failed before.
Theorem BTree.insert_search_false_of_ne: old failed searches for keys different from the inserted key remain failed after insertion.
Theorem BTree.insert_not_mem_iff: membership after insertion fails exactly for keys different from the inserted key that were absent before.
Theorem BTree.insert_not_mem_of_ne: old absent keys different from the inserted key remain absent after insertion.
Theorems BTree.insert_mem_self and BTree.insert_search_self: the inserted key is present and searchable after insertion.
Theorem BTree.insert_search_of_eq: any query key equal to the inserted key is searchable after insertion.
Theorems BTree.insert_mem_old and BTree.insert_search_old: old members and searchable keys remain so after insertion.
Theorems BTree.insert_search_of_mem and BTree.insert_search_false_of_not_mem_ne: old membership and absent noninserted keys give direct post-insertion search results.
Definitions BTree.splitRoot and BTree.insertRoot: the top-level CLRS operation splits a full root and then descends with BTree.insertNonFull.
Theorems BTree.splitRoot_keys_perm, BTree.splitRoot_wellFormed, BTree.splitRoot_height, BTree.splitRoot_rootKeyCount, and BTree.splitRoot_nonFull: splitting a full root preserves its keys, produces a well-formed one-key non-full root, and adds exactly one level.
Theorems BTree.insertRoot_keys_perm, BTree.insertRoot_wellFormed, and BTree.insertRoot_height: top-level insertion adds exactly one key, preserves BTree.WellFormed, and has the exact full-root conditional height equation.
Theorems BTree.insertRoot_mem_iff, BTree.insertRoot_mem_iff_insert, BTree.insertRoot_search_eq_insert, and BTree.insertRoot_searchExec_true_iff: executable insertion has exact membership semantics, agrees extensionally with specification insertion, and supports correct executable search.
Theorem BTree.insertRoot_wellFormedUnique: uniqueness is preserved when the inserted key was absent.
Theorem BTree.insertRoot_correct: exact add-one key semantics, well-formedness, and same-or-one-higher height are bundled together.

Model boundary: the flat BTree.insert remains the specification layer. BTree.splitRoot installs the old full root under a transient empty parent and applies the full-child split; that transient parent itself is not claimed to be BTree.WellFormed. The proved compatibility between BTree.insertRoot and BTree.insert is membership/search compatibility, not executable/specification tree-shape equality.

Section 18.2 is proved for the current functional correctness model. Disk pages, pointer mutation, I/O counts, and RAM costs are optional refinements.

              namespace CLRSnamespace Chapter18namespace BTree

Compatibility wrappers for `B-TREE-SPLIT-CHILD`

Internal bridge from the degree-only Valid predicate to splitChild's key-multiset preservation theorem.


theorem splitChild_keys_perm_valid {minDegree : Nat} {tr : BTree} {i : Nat}
    (hvalid : Valid minDegree tr) :
    (keysOf (splitChild minDegree tr i)).Perm (keysOf tr) := by
  cases tr with
  | node keys children =>
      change 2 ≤ minDegree at hvalid
      by_cases h_lt : i < children.length
      · cases hchild_eq : children.get ⟨i, h_lt⟩ with
        | node cKeys cChildren =>
            by_cases hfull : cKeys.length = 2 * minDegree - 1
            · exact splitChild_keys_perm minDegree hvalid keys children cKeys cChildren i
                h_lt hchild_eq hfull
            · dsimp [splitChild]
              rw [dif_pos h_lt]
              have h_get : children[i] = node cKeys cChildren := by
                simpa using hchild_eq
              rw [h_get]
              simp [hfull]
      · simp [splitChild, h_lt]

Splitting a child preserves degree-only Valid and every key membership fact. Structural preservation is stated separately by splitChild_preserves_wellFormed.

theorem splitChild_preserves_model {minDegree : Nat} {tr : BTree} {i : Nat}
    (hvalid : Valid minDegree tr) :
    Valid minDegree (splitChild minDegree tr i) ∧
      ∀ x, mem x (splitChild minDegree tr i) ↔ mem x tr := by
  refine ⟨hvalid, ?_⟩
  intro x
  exact (splitChild_keys_perm_valid
    (minDegree := minDegree) (tr := tr) (i := i) hvalid).mem_iff

Splitting a child preserves degree-only Valid; this is not a structural invariant.

theorem splitChild_valid {minDegree : Nat} {tr : BTree} {i : Nat}
    (hvalid : Valid minDegree tr) :
    Valid minDegree (splitChild minDegree tr i) :=
  (splitChild_preserves_model
    (minDegree := minDegree) (tr := tr) (i := i) hvalid).1

Membership is unchanged by splitting a child.

theorem splitChild_mem_iff {minDegree x i : Nat} {tr : BTree}
    (hvalid : Valid minDegree tr) :
    mem x (splitChild minDegree tr i) ↔ mem x tr :=
  (splitChild_preserves_model
    (minDegree := minDegree) (tr := tr) (i := i) hvalid).2 x

Every old member remains a member after splitting a child.

theorem splitChild_mem_old {minDegree x i : Nat} {tr : BTree}
    (hvalid : Valid minDegree tr) (hx : mem x tr) :
    mem x (splitChild minDegree tr i) :=
  (splitChild_mem_iff
    (minDegree := minDegree) (x := x) (i := i) (tr := tr) hvalid).2 hx

Non-membership is unchanged by splitting a child.

theorem splitChild_not_mem_iff {minDegree x i : Nat} {tr : BTree}
    (hvalid : Valid minDegree tr) :
    (¬ mem x (splitChild minDegree tr i)) ↔ ¬ mem x tr :=
  not_congr (splitChild_mem_iff
    (minDegree := minDegree) (x := x) (i := i) (tr := tr) hvalid)

Every old non-member remains absent after splitting a child.

theorem splitChild_not_mem_old {minDegree x i : Nat} {tr : BTree}
    (hvalid : Valid minDegree tr) (hx : ¬ mem x tr) :
    ¬ mem x (splitChild minDegree tr i) :=
  (splitChild_not_mem_iff
    (minDegree := minDegree) (x := x) (i := i) (tr := tr) hvalid).2 hx

Successful search is unchanged by splitting a child.

theorem splitChild_search_iff {minDegree x i : Nat} {tr : BTree}
    (hvalid : Valid minDegree tr) :
    search x (splitChild minDegree tr i) = true ↔ search x tr = true := by
  simpa only [search_true_iff] using
    (splitChild_mem_iff
      (minDegree := minDegree) (x := x) (i := i) (tr := tr) hvalid)

Every old successful search remains successful after splitting a child.

theorem splitChild_search_old {minDegree x i : Nat} {tr : BTree}
    (hvalid : Valid minDegree tr) (hx : search x tr = true) :
    search x (splitChild minDegree tr i) = true :=
  (splitChild_search_iff
    (minDegree := minDegree) (x := x) (i := i) (tr := tr) hvalid).2 hx

Every old member is searchable after splitting a child.

theorem splitChild_search_of_mem {minDegree x i : Nat} {tr : BTree}
    (hvalid : Valid minDegree tr) (hx : mem x tr) :
    search x (splitChild minDegree tr i) = true :=
  splitChild_search_old
    (minDegree := minDegree) (x := x) (i := i) (tr := tr)
    hvalid (search_true_of_mem x tr hx)

Failed search is unchanged by splitting a child.

theorem splitChild_search_false_iff {minDegree x i : Nat} {tr : BTree}
    (hvalid : Valid minDegree tr) :
    search x (splitChild minDegree tr i) = false ↔ search x tr = false := by
  simpa only [search_false_iff] using
    (splitChild_not_mem_iff
      (minDegree := minDegree) (x := x) (i := i) (tr := tr) hvalid)

Every old failed search remains failed after splitting a child.

theorem splitChild_search_false_old {minDegree x i : Nat} {tr : BTree}
    (hvalid : Valid minDegree tr) (hx : search x tr = false) :
    search x (splitChild minDegree tr i) = false :=
  (splitChild_search_false_iff
    (minDegree := minDegree) (x := x) (i := i) (tr := tr) hvalid).2 hx

Every old non-member remains an unsuccessful search after splitting a child.

theorem splitChild_search_false_of_not_mem {minDegree x i : Nat} {tr : BTree}
    (hvalid : Valid minDegree tr) (hx : ¬ mem x tr) :
    search x (splitChild minDegree tr i) = false :=
  splitChild_search_false_old
    (minDegree := minDegree) (x := x) (i := i) (tr := tr)
    hvalid (search_false_of_not_mem x tr hx)

Specification-level B-tree insertion: add the key at a fresh root.

def insert (x : Nat) (t : BTree) : BTree :=
  node (x :: keysOf t) []

Specification insertion preserves the first-pass validity predicate.

theorem insert_preserves_model {minDegree x : Nat} {t : BTree}
    (hvalid : Valid minDegree t) :
    Valid minDegree (insert x t) := by
  exact hvalid

Specification insertion preserves validity under the direct operation name.

theorem insert_valid {minDegree x : Nat} {t : BTree}
    (hvalid : Valid minDegree t) :
    Valid minDegree (insert x t) := by
  exact insert_preserves_model (minDegree := minDegree) (x := x) (t := t) hvalid

Specification insertion adds exactly the inserted key to membership.

theorem insert_mem_iff (x y : Nat) (t : BTree) :
    mem y (insert x t) <-> y = x ∨ mem y t := by
  simp [insert, mem, keysOf]

The inserted key is present after specification insertion.


theorem insert_mem_self (x : Nat) (t : BTree) :
    mem x (insert x t) := by
  rw [insert_mem_iff]
  exact Or.inl rfl

Old keys remain present after specification insertion.


theorem insert_mem_old (x y : Nat) (t : BTree) (hy : mem y t) :
    mem y (insert x t) := by
  rw [insert_mem_iff]
  exact Or.inr hy

Membership after insertion fails exactly for noninserted keys absent before insertion.


theorem insert_not_mem_iff (x y : Nat) (t : BTree) :
    ¬ mem y (insert x t) <-> y ≠ x ∧ ¬ mem y t := by
  rw [insert_mem_iff]
  constructor
  · intro hnot
    constructor
    · intro hyx
      exact hnot (Or.inl hyx)
    · intro hy
      exact hnot (Or.inr hy)
  · intro h hmem
    cases hmem with
    | inl hyx => exact h.1 hyx
    | inr hy => exact h.2 hy

Old absent keys different from the inserted key remain absent after insertion.


theorem insert_not_mem_of_ne (x y : Nat) (t : BTree)
    (hxy : y ≠ x) (hy : ¬ mem y t) :
    ¬ mem y (insert x t) := by
  rw [insert_not_mem_iff]
  exact ⟨hxy, hy⟩

Searching after insertion succeeds exactly for the new key or an old key.


theorem insert_search_iff {minDegree x y : Nat} {t : BTree}
    (hvalid : Valid minDegree t) :
    search y (insert x t) = true <-> y = x ∨ search y t = true := by
  have hinsert : Valid minDegree (insert x t) :=
    insert_preserves_model (minDegree := minDegree) (x := x) (t := t) hvalid
  rw [search_correct (minDegree := minDegree) (x := y) (t := insert x t) hinsert]
  rw [insert_mem_iff]
  rw [← search_correct (minDegree := minDegree) (x := y) (t := t) hvalid]

Searching for the inserted key succeeds after specification insertion.


theorem insert_search_self {minDegree x : Nat} {t : BTree}
    (hvalid : Valid minDegree t) :
    search x (insert x t) = true := by
  have hinsert : Valid minDegree (insert x t) :=
    insert_preserves_model (minDegree := minDegree) (x := x) (t := t) hvalid
  rw [search_correct (minDegree := minDegree) (x := x) (t := insert x t) hinsert]
  exact insert_mem_self x t

Any key equal to the inserted key is searchable after specification insertion.


theorem insert_search_of_eq {minDegree x y : Nat} {t : BTree}
    (hvalid : Valid minDegree t) (hyx : y = x) :
    search y (insert x t) = true := by
  rw [hyx]
  exact insert_search_self (minDegree := minDegree) (x := x) (t := t) hvalid

Old searchable keys remain searchable after specification insertion.


theorem insert_search_old {minDegree x y : Nat} {t : BTree}
    (hvalid : Valid minDegree t) (hy : search y t = true) :
    search y (insert x t) = true := by
  rw [insert_search_iff (minDegree := minDegree) (x := x) (y := y) (t := t) hvalid]
  exact Or.inr hy

Old members are directly searchable after specification insertion.

theorem insert_search_of_mem {minDegree x y : Nat} {t : BTree}
    (hvalid : Valid minDegree t) (hy : mem y t) :
    search y (insert x t) = true := by
  exact insert_search_old (minDegree := minDegree) (x := x) (y := y) (t := t)
    hvalid (search_true_of_mem y t hy)

Searching after insertion fails exactly for noninserted keys that failed before.


theorem insert_search_false_iff {minDegree x y : Nat} {t : BTree}
    (hvalid : Valid minDegree t) :
    search y (insert x t) = false <-> y ≠ x ∧ search y t = false := by
  constructor
  · intro hinsertFalse
    constructor
    · intro hyx
      have hinsertTrue : search y (insert x t) = true :=
        (insert_search_iff (minDegree := minDegree) (x := x) (y := y) (t := t) hvalid).mpr
          (Or.inl hyx)
      rw [hinsertFalse] at hinsertTrue
      contradiction
    · cases hold : search y t
      · rfl
      · have hinsertTrue : search y (insert x t) = true :=
          (insert_search_iff (minDegree := minDegree) (x := x) (y := y) (t := t) hvalid).mpr
            (Or.inr hold)
        rw [hinsertFalse] at hinsertTrue
        contradiction
  · intro h
    rcases h with ⟨hyx, holdFalse⟩
    cases hinsert : search y (insert x t)
    · rfl
    · have hcases : y = x ∨ search y t = true :=
        (insert_search_iff (minDegree := minDegree) (x := x) (y := y) (t := t) hvalid).mp
          hinsert
      cases hcases with
      | inl hyxEq =>
          exact False.elim (hyx hyxEq)
      | inr holdTrue =>
          rw [holdFalse] at holdTrue
          contradiction

Old failed searches for keys different from the inserted key remain failed.


theorem insert_search_false_of_ne {minDegree x y : Nat} {t : BTree}
    (hvalid : Valid minDegree t) (hxy : y ≠ x) (hy : search y t = false) :
    search y (insert x t) = false := by
  rw [insert_search_false_iff (minDegree := minDegree) (x := x) (y := y) (t := t) hvalid]
  exact ⟨hxy, hy⟩

Old absent keys different from the inserted key are directly failed searches after insertion.

theorem insert_search_false_of_not_mem_ne {minDegree x y : Nat} {t : BTree}
    (hvalid : Valid minDegree t) (hxy : y ≠ x) (hy : ¬ mem y t) :
    search y (insert x t) = false := by
  exact insert_search_false_of_ne
    (minDegree := minDegree) (x := x) (y := y) (t := t)
    hvalid hxy (search_false_of_not_mem y t hy)

Real recursive insertion (CLRS `B-TREE-INSERT-NONFULL`)

The specification insert above is a flat stub. The following develops the genuine CLRS recursive insertion. insertNonFull descends into the child that should hold x, splitting any full child on the way down (via the ordering of splitChild), and terminates on the tree height heightOf.

open List

Insert x into a sorted Nat list, preserving sortedness.

def sortedInsert (x : Nat) : List Nat → List Nat
  | [] => [x]
  | k :: ks => if x ≤ k then x :: k :: ks else k :: sortedInsert x ks

`insertNonFull`

CLRS B-TREE-INSERT-NONFULL. Assumes (for correctness) that the node is not full. On a leaf, x is inserted in sorted order. On an internal node, we find the child i that should hold x; if that child is full we split it (its median rises into this node and it becomes two half-children), then recurse into whichever half x belongs to. Terminates on heightOf since every recursive call is on a strictly shorter subtree.

def insertNonFull (t x : Nat) : BTree → BTree
  | node ks cs =>
    if cs.isEmpty then
      node (sortedInsert x ks) []
    else
      let i := findChild ks x
      match _hc : cs[i]? with
      | none => node ks cs
      | some c =>
        match _hcc : c with
        | node cKeys cChildren =>
          if cKeys.length = 2 * t - 1 then
            let median := cKeys.getD (t - 1) 0
            if x < median then
              node (ks.take i ++ median :: ks.drop i)
                (cs.take i ++
                  [insertNonFull t x (node (cKeys.take (t - 1)) (cChildren.take t)),
                   node (cKeys.drop t) (cChildren.drop t)] ++ cs.drop (i + 1))
            else
              node (ks.take i ++ median :: ks.drop i)
                (cs.take i ++
                  [node (cKeys.take (t - 1)) (cChildren.take t),
                   insertNonFull t x (node (cKeys.drop t) (cChildren.drop t))] ++ cs.drop (i + 1))
          else
            node ks (cs.set i (insertNonFull t x c))
termination_by tr => heightOf tr
decreasing_by
  all_goals
    have hmem : node cKeys cChildren ∈ cs := List.mem_iff_getElem?.mpr ⟨i, _hc⟩
    refine lt_of_le_of_lt ?_ (heightOf_mem_lt hmem)
    first
      | exact le_of_eq (congrArg heightOf _hcc)
      | exact heightOf_le_of_children_subset (List.take_subset _ _)
      | exact heightOf_le_of_children_subset (List.drop_subset _ _)

`sortedInsert` correctness

sortedInsert x ks is a permutation of x :: ks (adds exactly x).

lemma sortedInsert_perm (x : Nat) (ks : List Nat) : (sortedInsert x ks).Perm (x :: ks) := by
  induction ks with
  | nil => simp [sortedInsert]
  | cons k ks ih =>
    unfold sortedInsert
    split
    · exact List.Perm.refl _
    · calc k :: sortedInsert x ks ~ k :: x :: ks := ih.cons k
        _ ~ x :: k :: ks := List.Perm.swap x k ks

Membership after sortedInsert.


lemma mem_sortedInsert {x y : Nat} {ks : List Nat} :
    y ∈ sortedInsert x ks ↔ y = x ∨ y ∈ ks := by
  rw [(sortedInsert_perm x ks).mem_iff, List.mem_cons]

sortedInsert preserves sortedness.


lemma sortedInsert_sorted (x : Nat) : ∀ {ks : List Nat}, List.Pairwise (· ≤ ·) ks →
    List.Pairwise (· ≤ ·) (sortedInsert x ks) := by
  intro ks
  induction ks with
  | nil => intro _; simp [sortedInsert]
  | cons k ks ih =>
    intro h
    have hk : ∀ y ∈ ks, k ≤ y := (List.pairwise_cons.mp h).1
    have htail : List.Pairwise (· ≤ ·) ks := (List.pairwise_cons.mp h).2
    unfold sortedInsert
    split
    · rename_i hxk
      refine List.pairwise_cons.mpr ⟨?_, h⟩
      intro y hy
      rcases List.mem_cons.mp hy with rfl | hy
      · exact hxk
      · exact le_trans hxk (hk y hy)
    · rename_i hxk
      have hkx : k ≤ x := le_of_lt (not_le.mp hxk)
      refine List.pairwise_cons.mpr ⟨?_, ih htail⟩
      intro y hy
      rw [mem_sortedInsert] at hy
      rcases hy with rfl | hy
      · exact hkx
      · exact hk y hy

`insertNonFull` key multiset

insertNonFull adds exactly the key x to the key multiset (needs ChildBounded to rule out the out-of-range junk branch).


theorem insertNonFull_keys_perm (t x : Nat) (ht : 2 ≤ t) :
    ∀ (tr : BTree), ChildBounded tr →
      (keysOf (insertNonFull t x tr)).Perm (keysOf tr ++ [x]) := by
  intro tr
  induction tr using insertNonFull.induct (t := t) (x := x) with
  | case1 ks cs hempty =>
    intro _
    have hcsnil : cs = [] := List.isEmpty_iff.mp hempty
    subst hcsnil
    rw [insertNonFull]
    simp only [List.isEmpty_nil, if_true, keysOf, List.flatMap_nil, List.append_nil]
    exact (sortedInsert_perm x ks).trans (List.perm_append_comm (l₁ := [x]) (l₂ := ks))
  | case2 ks cs hne i hnone =>
    intro hcb
    exfalso
    have hlen : cs.length = ks.length + 1 := by
      unfold ChildBounded at hcb
      rcases hcb with ⟨hrel, _, _⟩
      rcases hrel with hemp | heq
      · have : cs = [] := List.isEmpty_iff.mp hemp
        rw [this] at hne; simp at hne
      · exact heq
    have h1 : cs.length ≤ i := List.getElem?_eq_none_iff.mp hnone
    have h2 : i ≤ ks.length := findChild_le ks x
    omega
  | case3 ks cs hne i cKeys cChildren hsome hfull median hlt hsome2 ih =>
    intro hcb
    have hsome' : cs[findChild ks x]? = some (node cKeys cChildren) := hsome
    obtain ⟨hilt, hget⟩ := List.getElem?_eq_some_iff.mp hsome'
    have hcb_child : ChildBounded (node cKeys cChildren) := by
      unfold ChildBounded at hcb; rcases hcb with ⟨_, _, hsub⟩
      exact hsub _ (List.mem_iff_getElem?.mpr ⟨findChild ks x, hsome'⟩)
    have ht1 : t - 1 < cKeys.length := by rw [hfull]; omega
    have hcb_left : ChildBounded (node (cKeys.take (t - 1)) (cChildren.take t)) := by
      have h := childBounded_take_of_full hcb_child ht1
      rwa [show (t - 1) + 1 = t from by omega] at h
    have ihc := ih hcb_left
    have hmed : cKeys.getD (t - 1) 0 = cKeys[t - 1] := by
      simp only [List.getD_eq_getElem?_getD, List.getElem?_eq_getElem ht1, Option.getD_some]
    have hval : insertNonFull t x (node ks cs)
        = node (ks.take (findChild ks x) ++ cKeys.getD (t - 1) 0 :: ks.drop (findChild ks x))
            (cs.take (findChild ks x) ++
              [insertNonFull t x (node (cKeys.take (t - 1)) (cChildren.take t)),
               node (cKeys.drop t) (cChildren.drop t)] ++ cs.drop (findChild ks x + 1)) := by
      rw [insertNonFull, if_neg hne]
      dsimp only
      split
      · rename_i hcnone; rw [hsome'] at hcnone; exact absurd hcnone (by simp)
      · rename_i c hcsome
        obtain rfl : c = node cKeys cChildren := by
          rw [hsome'] at hcsome; injection hcsome with h; exact h.symm
        dsimp only
        rw [if_pos hfull, if_pos hlt]
    rw [hval, hmed]
    set med := cKeys[t - 1] with hmedeq
    set LK := cKeys.take (t - 1) with hLK
    set RK := cKeys.drop t with hRK
    set LC := cChildren.take t with hLC
    set RC := cChildren.drop t with hRC
    rw [← Multiset.coe_eq_coe]
    have hcs : cs = cs.take (findChild ks x) ++ node cKeys cChildren
        :: cs.drop (findChild ks x + 1) := by
      conv_lhs => rw [← List.take_append_drop (findChild ks x) cs]
      rw [List.drop_eq_getElem_cons hilt, hget]
    have hck : cKeys = LK ++ med :: RK := by
      rw [hLK, hRK, hmedeq]
      conv_lhs => rw [← List.take_append_drop (t - 1) cKeys]
      rw [List.drop_eq_getElem_cons ht1, show (t - 1) + 1 = t from by omega]
    have hcc : cChildren = LC ++ RC := by rw [hLC, hRC]; exact (List.take_append_drop t cChildren).symm
    have hihc : (↑(keysOf (insertNonFull t x (node LK LC))) : Multiset Nat)
        = ↑(keysOf (node LK LC)) + ↑([x] : List Nat) :=
      (Multiset.coe_eq_coe.mpr ihc).trans (Multiset.coe_add _ _).symm
    conv_lhs => rw [keysOf]
    conv_rhs => rw [keysOf, hcs]
    simp only [List.flatMap_append, List.flatMap_cons, List.flatMap_nil, List.append_nil, keysOf,
      hck, hcc, ← Multiset.coe_add, ← Multiset.cons_coe,
      ← Multiset.singleton_add, hihc]
    rw [show (↑ks : Multiset Nat) = ↑(ks.take (findChild ks x)) + ↑(ks.drop (findChild ks x)) from by
      rw [Multiset.coe_add, List.take_append_drop]]
    abel
  | case4 ks cs hne i cKeys cChildren hsome hfull median hnlt hsome2 ih =>
    intro hcb
    have hsome' : cs[findChild ks x]? = some (node cKeys cChildren) := hsome
    obtain ⟨hilt, hget⟩ := List.getElem?_eq_some_iff.mp hsome'
    have hcb_child : ChildBounded (node cKeys cChildren) := by
      unfold ChildBounded at hcb; rcases hcb with ⟨_, _, hsub⟩
      exact hsub _ (List.mem_iff_getElem?.mpr ⟨findChild ks x, hsome'⟩)
    have ht1 : t - 1 < cKeys.length := by rw [hfull]; omega
    have hcb_right : ChildBounded (node (cKeys.drop t) (cChildren.drop t)) := by
      rcases child_children_len_of_full_cb ht hcb_child hfull with h0 | h2t
      · have hnil : cChildren = [] := by cases cChildren with | nil => rfl | cons a b => simp at h0
        rw [hnil]; simpa using childBounded_node_nil (cKeys.drop t)
      · exact childBounded_drop_of_full hcb_child (by omega) (by rw [h2t]; omega)
    have ihc := ih hcb_right
    have hmed : cKeys.getD (t - 1) 0 = cKeys[t - 1] := by
      simp only [List.getD_eq_getElem?_getD, List.getElem?_eq_getElem ht1, Option.getD_some]
    have hval : insertNonFull t x (node ks cs)
        = node (ks.take (findChild ks x) ++ cKeys.getD (t - 1) 0 :: ks.drop (findChild ks x))
            (cs.take (findChild ks x) ++
              [node (cKeys.take (t - 1)) (cChildren.take t),
               insertNonFull t x (node (cKeys.drop t) (cChildren.drop t))]
              ++ cs.drop (findChild ks x + 1)) := by
      rw [insertNonFull, if_neg hne]
      dsimp only
      split
      · rename_i hcnone; rw [hsome'] at hcnone; exact absurd hcnone (by simp)
      · rename_i c hcsome
        obtain rfl : c = node cKeys cChildren := by
          rw [hsome'] at hcsome; injection hcsome with h; exact h.symm
        dsimp only
        rw [if_pos hfull, if_neg hnlt]
    rw [hval, hmed]
    set med := cKeys[t - 1] with hmedeq
    set LK := cKeys.take (t - 1) with hLK
    set RK := cKeys.drop t with hRK
    set LC := cChildren.take t with hLC
    set RC := cChildren.drop t with hRC
    rw [← Multiset.coe_eq_coe]
    have hcs : cs = cs.take (findChild ks x) ++ node cKeys cChildren
        :: cs.drop (findChild ks x + 1) := by
      conv_lhs => rw [← List.take_append_drop (findChild ks x) cs]
      rw [List.drop_eq_getElem_cons hilt, hget]
    have hck : cKeys = LK ++ med :: RK := by
      rw [hLK, hRK, hmedeq]
      conv_lhs => rw [← List.take_append_drop (t - 1) cKeys]
      rw [List.drop_eq_getElem_cons ht1, show (t - 1) + 1 = t from by omega]
    have hcc : cChildren = LC ++ RC := by rw [hLC, hRC]; exact (List.take_append_drop t cChildren).symm
    have hihc : (↑(keysOf (insertNonFull t x (node RK RC))) : Multiset Nat)
        = ↑(keysOf (node RK RC)) + ↑([x] : List Nat) :=
      (Multiset.coe_eq_coe.mpr ihc).trans (Multiset.coe_add _ _).symm
    conv_lhs => rw [keysOf]
    conv_rhs => rw [keysOf, hcs]
    simp only [List.flatMap_append, List.flatMap_cons, List.flatMap_nil, List.append_nil, keysOf,
      hck, hcc, ← Multiset.coe_add, ← Multiset.cons_coe,
      ← Multiset.singleton_add, hihc]
    rw [show (↑ks : Multiset Nat) = ↑(ks.take (findChild ks x)) + ↑(ks.drop (findChild ks x)) from by
      rw [Multiset.coe_add, List.take_append_drop]]
    abel
  | case5 ks cs hne i cKeys cChildren hsome hnfull hsome2 ih =>
    intro hcb
    have hsome' : cs[findChild ks x]? = some (node cKeys cChildren) := hsome
    obtain ⟨hilt, hget⟩ := List.getElem?_eq_some_iff.mp hsome'
    have hcb_child : ChildBounded (node cKeys cChildren) := by
      unfold ChildBounded at hcb; rcases hcb with ⟨_, _, hsub⟩
      exact hsub _ (List.mem_iff_getElem?.mpr ⟨findChild ks x, hsome'⟩)
    have ihc := ih hcb_child
    have hval : insertNonFull t x (node ks cs)
        = node ks (cs.set (findChild ks x) (insertNonFull t x (node cKeys cChildren))) := by
      rw [insertNonFull, if_neg hne]
      dsimp only
      split
      · rename_i hcnone; rw [hsome'] at hcnone; exact absurd hcnone (by simp)
      · rename_i c hcsome
        obtain rfl : c = node cKeys cChildren := by
          rw [hsome'] at hcsome; injection hcsome with h; exact h.symm
        dsimp only
        rw [if_neg hnfull]
    rw [hval, ← Multiset.coe_eq_coe]
    have hset : cs.set (findChild ks x) (insertNonFull t x (node cKeys cChildren))
        = cs.take (findChild ks x) ++ insertNonFull t x (node cKeys cChildren)
          :: cs.drop (findChild ks x + 1) := by
      rw [List.set_eq_take_append_cons_drop, if_pos hilt]
    have hcs : cs = cs.take (findChild ks x) ++ node cKeys cChildren
        :: cs.drop (findChild ks x + 1) := by
      conv_lhs => rw [← List.take_append_drop (findChild ks x) cs]
      rw [List.drop_eq_getElem_cons hilt, hget]
    have hihc : (↑(keysOf (insertNonFull t x (node cKeys cChildren))) : Multiset Nat)
        = ↑(keysOf (node cKeys cChildren)) + ↑([x] : List Nat) :=
      (Multiset.coe_eq_coe.mpr ihc).trans (Multiset.coe_add _ _).symm
    conv_lhs => rw [keysOf, hset]
    conv_rhs => rw [keysOf, hcs]
    simp only [List.flatMap_append, List.flatMap_cons, ← Multiset.coe_add, hihc]
    abel

`SameDepth` and height preservation

Membership characterisation of SameDepth: all children are SameDepth and share a common height. Easier to construct/destruct than the inductive form.

lemma sameDepth_iff {ks : List Nat} {cs : List BTree} :
    SameDepth (node ks cs) ↔
      (∀ c ∈ cs, SameDepth c) ∧ ∀ c ∈ cs, ∀ d ∈ cs, heightOf c = heightOf d := by
  constructor
  · intro hsd
    refine ⟨?_, ?_⟩
    · intro c hc
      cases cs with
      | nil => simp at hc
      | cons c0 cs' =>
        rcases List.mem_cons.mp hc with rfl | hc'
        · exact sameDepth_head_sd hsd
        · exact sameDepth_tail_sd hsd c hc'
    · cases cs with
      | nil => intro c hc; simp at hc
      | cons c0 cs' => exact sameDepth_children_eq_height hsd
  · rintro ⟨hsd_all, hheight⟩
    cases cs with
    | nil => exact SameDepth.leaf ks
    | cons c0 cs' =>
      refine SameDepth.internal ks c0 cs' ?_ ?_ ?_
      · intro c hc; exact hheight c (by simp [hc]) c0 (by simp)
      · exact hsd_all c0 (by simp)
      · intro c hc; exact hsd_all c (by simp [hc])

For a SameDepth node, its height is one more than any child's height.


lemma heightOf_sameDepth_mem {ks : List Nat} {cs : List BTree} {c : BTree}
    (hsd : SameDepth (node ks cs)) (hc : c ∈ cs) : heightOf (node ks cs) = 1 + heightOf c := by
  cases cs with
  | nil => simp at hc
  | cons c0 cs' =>
    rw [heightOf_internal_of_sameDepth hsd]
    congr 1
    exact (sameDepth_iff.mp hsd).2 c0 (by simp) c hc

heightOf depends only on the children, not the keys.

lemma heightOf_keys_irrel (a b : List Nat) (cs : List BTree) :
    heightOf (node a cs) = heightOf (node b cs) := by
  cases cs with
  | nil => simp [heightOf]
  | cons c cs' => simp only [heightOf]

Height of the two split halves equals the height of the original full child.


lemma heightOf_halves_eq {t : Nat} {cKeys : List Nat} {cChildren : List BTree}
    (hsd : SameDepth (node cKeys cChildren)) (ht_pos : 0 < t)
    (h_children : cChildren = [] ∨ t < cChildren.length) :
    heightOf (node (cKeys.take (t - 1)) (cChildren.take t)) = heightOf (node cKeys cChildren) ∧
    heightOf (node (cKeys.drop t) (cChildren.drop t)) = heightOf (node cKeys cChildren) := by
  have h := heightOf_split_parts_eq cKeys cChildren t hsd ht_pos h_children
  simp only [List.splitAt_eq] at h
  refine ⟨h.1, ?_⟩
  rw [heightOf_keys_irrel (cKeys.drop t) ((cKeys.drop (t - 1)).drop 1) (cChildren.drop t)]
  exact h.2

insertNonFull preserves SameDepth and the total height (given the tree is ChildBounded and SameDepth).


lemma insertNonFull_sameDepth_height (t x : Nat) (ht : 2 ≤ t) :
    ∀ tr, ChildBounded tr → SameDepth tr →
      SameDepth (insertNonFull t x tr) ∧ heightOf (insertNonFull t x tr) = heightOf tr := by
  intro tr
  induction tr using insertNonFull.induct (t := t) (x := x) with
  | case1 ks cs hempty =>
    intro _ _
    have hcsnil : cs = [] := List.isEmpty_iff.mp hempty
    subst hcsnil
    rw [insertNonFull]
    simp only [List.isEmpty_nil, if_true]
    exact ⟨SameDepth.leaf _, heightOf_keys_irrel _ _ _⟩
  | case2 ks cs hne i hnone =>
    intro _ hsd
    have hval : insertNonFull t x (node ks cs) = node ks cs := by
      rw [insertNonFull, if_neg hne]; dsimp only
      split
      · rfl
      · rename_i c hcsome
        have hn : cs[findChild ks x]? = none := hnone
        rw [hcsome] at hn; simp at hn
    rw [hval]; exact ⟨hsd, rfl⟩
  | case3 ks cs hne i cKeys cChildren hsome hfull median hlt hsome2 ih =>
    intro hcb hsd
    have hsome' : cs[findChild ks x]? = some (node cKeys cChildren) := hsome
    obtain ⟨hilt, hget⟩ := List.getElem?_eq_some_iff.mp hsome'
    have hmem : node cKeys cChildren ∈ cs := List.mem_iff_getElem?.mpr ⟨_, hsome'⟩
    have hcb_child : ChildBounded (node cKeys cChildren) := by
      unfold ChildBounded at hcb; rcases hcb with ⟨_, _, hsub⟩; exact hsub _ hmem
    have hsd_child : SameDepth (node cKeys cChildren) := (sameDepth_iff.mp hsd).1 _ hmem
    have ht1 : t - 1 < cKeys.length := by rw [hfull]; omega
    have h_children : cChildren = [] ∨ t < cChildren.length := by
      rcases child_children_len_of_full_cb ht hcb_child hfull with h0 | h2t
      · left; cases cChildren with | nil => rfl | cons a b => simp at h0
      · right; rw [h2t]; omega
    have hcb_LH : ChildBounded (node (cKeys.take (t - 1)) (cChildren.take t)) := by
      have h := childBounded_take_of_full hcb_child ht1
      rwa [show (t - 1) + 1 = t from by omega] at h
    have hsd_LH : SameDepth (node (cKeys.take (t - 1)) (cChildren.take t)) := by
      have h := sameDepth_take cKeys cChildren t hsd_child (by omega)
      simpa [List.splitAt_eq] using h
    have hsd_RH : SameDepth (node (cKeys.drop t) (cChildren.drop t)) := by
      have h := sameDepth_drop cKeys cChildren t hsd_child (by omega)
      simp only [List.splitAt_eq] at h
      rw [sameDepth_iff] at h ⊢; exact h
    obtain ⟨ihsd, ihht⟩ := ih hcb_LH hsd_LH
    have hheq := heightOf_halves_eq hsd_child (by omega) h_children
    have hval : insertNonFull t x (node ks cs)
        = node (ks.take (findChild ks x) ++ cKeys.getD (t - 1) 0 :: ks.drop (findChild ks x))
            (cs.take (findChild ks x) ++
              [insertNonFull t x (node (cKeys.take (t - 1)) (cChildren.take t)),
               node (cKeys.drop t) (cChildren.drop t)] ++ cs.drop (findChild ks x + 1)) := by
      rw [insertNonFull, if_neg hne]; dsimp only
      split
      · rename_i hcnone; rw [hsome'] at hcnone; exact absurd hcnone (by simp)
      · rename_i c hcsome
        obtain rfl : c = node cKeys cChildren := by
          rw [hsome'] at hcsome; injection hcsome with h; exact h.symm
        dsimp only; rw [if_pos hfull, if_pos hlt]
    rw [hval]
    have hHT : ∀ c'' ∈ cs.take (findChild ks x) ++
        [insertNonFull t x (node (cKeys.take (t - 1)) (cChildren.take t)),
         node (cKeys.drop t) (cChildren.drop t)] ++ cs.drop (findChild ks x + 1),
        heightOf c'' = heightOf (node cKeys cChildren) := by
      intro c'' hc''
      rcases List.mem_append.mp hc'' with h1 | h2
      · rcases List.mem_append.mp h1 with hta | hmid
        · exact (sameDepth_iff.mp hsd).2 c'' ((List.take_subset _ _) hta) _ hmem
        · simp only [List.mem_cons, List.not_mem_nil, or_false] at hmid
          rcases hmid with rfl | rfl
          · rw [ihht]; exact hheq.1
          · exact hheq.2
      · exact (sameDepth_iff.mp hsd).2 c'' ((List.drop_subset _ _) h2) _ hmem
    have hSD : ∀ c'' ∈ cs.take (findChild ks x) ++
        [insertNonFull t x (node (cKeys.take (t - 1)) (cChildren.take t)),
         node (cKeys.drop t) (cChildren.drop t)] ++ cs.drop (findChild ks x + 1),
        SameDepth c'' := by
      intro c'' hc''
      rcases List.mem_append.mp hc'' with h1 | h2
      · rcases List.mem_append.mp h1 with hta | hmid
        · exact (sameDepth_iff.mp hsd).1 c'' ((List.take_subset _ _) hta)
        · simp only [List.mem_cons, List.not_mem_nil, or_false] at hmid
          rcases hmid with rfl | rfl
          · exact ihsd
          · exact hsd_RH
      · exact (sameDepth_iff.mp hsd).1 c'' ((List.drop_subset _ _) h2)
    refine ⟨sameDepth_iff.mpr ⟨hSD, fun a ha b hb => (hHT a ha).trans (hHT b hb).symm⟩, ?_⟩
    have hmem_res : insertNonFull t x (node (cKeys.take (t - 1)) (cChildren.take t)) ∈
        cs.take (findChild ks x) ++
          [insertNonFull t x (node (cKeys.take (t - 1)) (cChildren.take t)),
           node (cKeys.drop t) (cChildren.drop t)] ++ cs.drop (findChild ks x + 1) := by
      apply List.mem_append_left; apply List.mem_append_right; simp
    rw [heightOf_sameDepth_mem (sameDepth_iff.mpr ⟨hSD, fun a ha b hb =>
          (hHT a ha).trans (hHT b hb).symm⟩) hmem_res, hHT _ hmem_res,
        heightOf_sameDepth_mem hsd hmem]
  | case4 ks cs hne i cKeys cChildren hsome hfull median hnlt hsome2 ih =>
    intro hcb hsd
    have hsome' : cs[findChild ks x]? = some (node cKeys cChildren) := hsome
    obtain ⟨hilt, hget⟩ := List.getElem?_eq_some_iff.mp hsome'
    have hmem : node cKeys cChildren ∈ cs := List.mem_iff_getElem?.mpr ⟨_, hsome'⟩
    have hcb_child : ChildBounded (node cKeys cChildren) := by
      unfold ChildBounded at hcb; rcases hcb with ⟨_, _, hsub⟩; exact hsub _ hmem
    have hsd_child : SameDepth (node cKeys cChildren) := (sameDepth_iff.mp hsd).1 _ hmem
    have ht1 : t - 1 < cKeys.length := by rw [hfull]; omega
    have h_children : cChildren = [] ∨ t < cChildren.length := by
      rcases child_children_len_of_full_cb ht hcb_child hfull with h0 | h2t
      · left; cases cChildren with | nil => rfl | cons a b => simp at h0
      · right; rw [h2t]; omega
    have hcb_RH : ChildBounded (node (cKeys.drop t) (cChildren.drop t)) := by
      rcases child_children_len_of_full_cb ht hcb_child hfull with h0 | h2t
      · have hnil : cChildren = [] := by cases cChildren with | nil => rfl | cons a b => simp at h0
        rw [hnil]; simpa using childBounded_node_nil (cKeys.drop t)
      · exact childBounded_drop_of_full hcb_child (by omega) (by rw [h2t]; omega)
    have hsd_RH : SameDepth (node (cKeys.drop t) (cChildren.drop t)) := by
      have h := sameDepth_drop cKeys cChildren t hsd_child (by omega)
      simp only [List.splitAt_eq] at h
      rw [sameDepth_iff] at h ⊢; exact h
    have hsd_LH : SameDepth (node (cKeys.take (t - 1)) (cChildren.take t)) := by
      have h := sameDepth_take cKeys cChildren t hsd_child (by omega)
      simpa [List.splitAt_eq] using h
    obtain ⟨ihsd, ihht⟩ := ih hcb_RH hsd_RH
    have hheq := heightOf_halves_eq hsd_child (by omega) h_children
    have hval : insertNonFull t x (node ks cs)
        = node (ks.take (findChild ks x) ++ cKeys.getD (t - 1) 0 :: ks.drop (findChild ks x))
            (cs.take (findChild ks x) ++
              [node (cKeys.take (t - 1)) (cChildren.take t),
               insertNonFull t x (node (cKeys.drop t) (cChildren.drop t))]
              ++ cs.drop (findChild ks x + 1)) := by
      rw [insertNonFull, if_neg hne]; dsimp only
      split
      · rename_i hcnone; rw [hsome'] at hcnone; exact absurd hcnone (by simp)
      · rename_i c hcsome
        obtain rfl : c = node cKeys cChildren := by
          rw [hsome'] at hcsome; injection hcsome with h; exact h.symm
        dsimp only; rw [if_pos hfull, if_neg hnlt]
    rw [hval]
    have hHT : ∀ c'' ∈ cs.take (findChild ks x) ++
        [node (cKeys.take (t - 1)) (cChildren.take t),
         insertNonFull t x (node (cKeys.drop t) (cChildren.drop t))] ++ cs.drop (findChild ks x + 1),
        heightOf c'' = heightOf (node cKeys cChildren) := by
      intro c'' hc''
      rcases List.mem_append.mp hc'' with h1 | h2
      · rcases List.mem_append.mp h1 with hta | hmid
        · exact (sameDepth_iff.mp hsd).2 c'' ((List.take_subset _ _) hta) _ hmem
        · simp only [List.mem_cons, List.not_mem_nil, or_false] at hmid
          rcases hmid with rfl | rfl
          · exact hheq.1
          · rw [ihht]; exact hheq.2
      · exact (sameDepth_iff.mp hsd).2 c'' ((List.drop_subset _ _) h2) _ hmem
    have hSD : ∀ c'' ∈ cs.take (findChild ks x) ++
        [node (cKeys.take (t - 1)) (cChildren.take t),
         insertNonFull t x (node (cKeys.drop t) (cChildren.drop t))] ++ cs.drop (findChild ks x + 1),
        SameDepth c'' := by
      intro c'' hc''
      rcases List.mem_append.mp hc'' with h1 | h2
      · rcases List.mem_append.mp h1 with hta | hmid
        · exact (sameDepth_iff.mp hsd).1 c'' ((List.take_subset _ _) hta)
        · simp only [List.mem_cons, List.not_mem_nil, or_false] at hmid
          rcases hmid with rfl | rfl
          · exact hsd_LH
          · exact ihsd
      · exact (sameDepth_iff.mp hsd).1 c'' ((List.drop_subset _ _) h2)
    refine ⟨sameDepth_iff.mpr ⟨hSD, fun a ha b hb => (hHT a ha).trans (hHT b hb).symm⟩, ?_⟩
    have hmem_res : node (cKeys.take (t - 1)) (cChildren.take t) ∈
        cs.take (findChild ks x) ++
          [node (cKeys.take (t - 1)) (cChildren.take t),
           insertNonFull t x (node (cKeys.drop t) (cChildren.drop t))] ++ cs.drop (findChild ks x + 1) := by
      apply List.mem_append_left; apply List.mem_append_right; simp
    rw [heightOf_sameDepth_mem (sameDepth_iff.mpr ⟨hSD, fun a ha b hb =>
          (hHT a ha).trans (hHT b hb).symm⟩) hmem_res, hHT _ hmem_res,
        heightOf_sameDepth_mem hsd hmem]
  | case5 ks cs hne i cKeys cChildren hsome hnfull hsome2 ih =>
    intro hcb hsd
    have hsome' : cs[findChild ks x]? = some (node cKeys cChildren) := hsome
    obtain ⟨hilt, hget⟩ := List.getElem?_eq_some_iff.mp hsome'
    have hmem : node cKeys cChildren ∈ cs := List.mem_iff_getElem?.mpr ⟨_, hsome'⟩
    have hcb_child : ChildBounded (node cKeys cChildren) := by
      unfold ChildBounded at hcb; rcases hcb with ⟨_, _, hsub⟩; exact hsub _ hmem
    have hsd_child : SameDepth (node cKeys cChildren) := (sameDepth_iff.mp hsd).1 _ hmem
    obtain ⟨ihsd, ihht⟩ := ih hcb_child hsd_child
    have hval : insertNonFull t x (node ks cs)
        = node ks (cs.set (findChild ks x) (insertNonFull t x (node cKeys cChildren))) := by
      rw [insertNonFull, if_neg hne]; dsimp only
      split
      · rename_i hcnone; rw [hsome'] at hcnone; exact absurd hcnone (by simp)
      · rename_i c hcsome
        obtain rfl : c = node cKeys cChildren := by
          rw [hsome'] at hcsome; injection hcsome with h; exact h.symm
        dsimp only; rw [if_neg hnfull]
    rw [hval]
    have hHT : ∀ c'' ∈ cs.set (findChild ks x) (insertNonFull t x (node cKeys cChildren)),
        heightOf c'' = heightOf (node cKeys cChildren) := by
      intro c'' hc''
      rcases List.mem_or_eq_of_mem_set hc'' with hcs | rfl
      · exact (sameDepth_iff.mp hsd).2 c'' hcs _ hmem
      · exact ihht
    have hSD : ∀ c'' ∈ cs.set (findChild ks x) (insertNonFull t x (node cKeys cChildren)),
        SameDepth c'' := by
      intro c'' hc''
      rcases List.mem_or_eq_of_mem_set hc'' with hcs | rfl
      · exact (sameDepth_iff.mp hsd).1 c'' hcs
      · exact ihsd
    refine ⟨sameDepth_iff.mpr ⟨hSD, fun a ha b hb => (hHT a ha).trans (hHT b hb).symm⟩, ?_⟩
    have hmem_res : insertNonFull t x (node cKeys cChildren) ∈
        cs.set (findChild ks x) (insertNonFull t x (node cKeys cChildren)) :=
      List.mem_set hilt _
    rw [heightOf_sameDepth_mem (sameDepth_iff.mpr ⟨hSD, fun a ha b hb =>
          (hHT a ha).trans (hHT b hb).symm⟩) hmem_res, hHT _ hmem_res,
        heightOf_sameDepth_mem hsd hmem]

insertNonFull preserves SameDepth.

lemma insertNonFull_sameDepth (t x : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hcb : ChildBounded tr) (hsd : SameDepth tr) : SameDepth (insertNonFull t x tr) :=
  (insertNonFull_sameDepth_height t x ht tr hcb hsd).1

insertNonFull preserves the total height.

lemma insertNonFull_height (t x : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hcb : ChildBounded tr) (hsd : SameDepth tr) :
    heightOf (insertNonFull t x tr) = heightOf tr :=
  (insertNonFull_sameDepth_height t x ht tr hcb hsd).2

Bridge to `splitChild` for the Sorted / ChildBounded proofs

Explicit output of splitChild on a full child: it inserts the median cKeys[t-1] into the parent keys and replaces the child by its two halves. This lets the insertion proofs reuse splitChild_preserves_sorted / splitChild_preserves_childBounded.


lemma splitChild_full_eq (t : Nat) (ht : 2 ≤ t) (ks : List Nat) (cs : List BTree) (i : Nat)
    (cKeys : List Nat) (cChildren : List BTree)
    (h_lt : i < cs.length) (hchild_eq : cs.get ⟨i, h_lt⟩ = node cKeys cChildren)
    (hchild_full : cKeys.length = 2 * t - 1) :
    splitChild t (node ks cs) i
      = node (ks.take i ++ cKeys[t - 1]'(by omega) :: ks.drop i)
          (cs.take i ++
            [node (cKeys.take (t - 1)) (cChildren.take t), node (cKeys.drop t) (cChildren.drop t)]
            ++ cs.drop (i + 1)) := by
  have ht1 : t - 1 < cKeys.length := by omega
  have h_keys_snd_nonempty : (cKeys.splitAt (t - 1)).2 ≠ [] := by
    have hlen : (cKeys.splitAt (t - 1)).2.length = t := by simp [hchild_full]; omega
    intro h; rw [h] at hlen; simp at hlen; omega
  dsimp [splitChild]; rw [dif_pos h_lt]
  have h_get : cs[i] = node cKeys cChildren := by simpa using hchild_eq
  rw [h_get]; dsimp; rw [if_pos hchild_full]
  cases hk : cKeys.splitAt (t - 1) with
  | mk leftKeys keysRest =>
    have hkr_ne : keysRest ≠ [] := by
      have : (cKeys.splitAt (t - 1)).2 = keysRest := by rw [hk]
      rw [← this]; exact h_keys_snd_nonempty
    cases hkr : keysRest with
    | nil => exact (hkr_ne hkr).elim
    | cons medianKey rightKeys =>
      cases hc : cChildren.splitAt t with
      | mk leftCh rightCh =>
        have h_lk : leftKeys = cKeys.take (t - 1) := by
          calc leftKeys = (cKeys.splitAt (t - 1)).1 := by rw [hk]
            _ = cKeys.take (t - 1) := by simp
        have h_keysRest_eq : keysRest = cKeys.drop (t - 1) := by
          calc keysRest = (cKeys.splitAt (t - 1)).2 := by rw [hk]
            _ = cKeys.drop (t - 1) := by simp
        have h_rk : rightKeys = cKeys.drop t := by
          calc rightKeys = keysRest.drop 1 := by rw [hkr]; simp
            _ = (cKeys.drop (t - 1)).drop 1 := by rw [h_keysRest_eq]
            _ = cKeys.drop ((t - 1) + 1) := by rw [← List.drop_drop]
            _ = cKeys.drop t := by rw [show (t - 1) + 1 = t from by omega]
        have h_lc : leftCh = cChildren.take t := by
          calc leftCh = (cChildren.splitAt t).1 := by rw [hc]
            _ = cChildren.take t := by simp
        have h_rc : rightCh = cChildren.drop t := by
          calc rightCh = (cChildren.splitAt t).2 := by rw [hc]
            _ = cChildren.drop t := by simp
        have h_med : medianKey = cKeys[t - 1] := by
          have hh : (cKeys.drop (t - 1))[0]? = some medianKey := by
            rw [← h_keysRest_eq, hkr]; rfl
          rw [List.getElem?_drop] at hh
          simp only [Nat.add_zero, List.getElem?_eq_getElem ht1] at hh
          injection hh with hh; exact hh.symm
        subst h_lk h_rk h_lc h_rc h_med
        rfl

Sorted restricts to a prefix of the keys/children.

lemma sorted_take {ks : List Nat} {cs : List BTree} (a b : Nat)
    (hs : Sorted (node ks cs)) : Sorted (node (ks.take a) (cs.take b)) := by
  unfold Sorted at hs ⊢
  exact ⟨List.Pairwise.take hs.1, fun c hc => hs.2 c ((List.take_subset _ _) hc)⟩

Sorted restricts to a suffix of the keys/children.

lemma sorted_drop {ks : List Nat} {cs : List BTree} (a b : Nat)
    (hs : Sorted (node ks cs)) : Sorted (node (ks.drop a) (cs.drop b)) := by
  unfold Sorted at hs ⊢
  exact ⟨List.Pairwise.drop hs.1, fun c hc => hs.2 c ((List.drop_subset _ _) hc)⟩

insertNonFull preserves Sorted (given the tree is ChildBounded and Sorted). The split cases reuse splitChild_preserves_sorted via splitChild_full_eq.


lemma insertNonFull_sorted (t x : Nat) (ht : 2 ≤ t) :
    ∀ tr, ChildBounded tr → Sorted tr → Sorted (insertNonFull t x tr) := by
  intro tr
  induction tr using insertNonFull.induct (t := t) (x := x) with
  | case1 ks cs hempty =>
    intro _ hs
    have hcsnil : cs = [] := List.isEmpty_iff.mp hempty
    subst hcsnil
    rw [insertNonFull]; simp only [List.isEmpty_nil, if_true]
    unfold Sorted at hs ⊢
    exact ⟨sortedInsert_sorted x hs.1, fun c hc => by simp at hc⟩
  | case2 ks cs hne i hnone =>
    intro _ hs
    have hval : insertNonFull t x (node ks cs) = node ks cs := by
      rw [insertNonFull, if_neg hne]; dsimp only
      split
      · rfl
      · rename_i c hcsome
        have hn : cs[findChild ks x]? = none := hnone; rw [hcsome] at hn; simp at hn
    rw [hval]; exact hs
  | case5 ks cs hne i cKeys cChildren hsome hnfull hsome2 ih =>
    intro hcb hs
    have hsome' : cs[findChild ks x]? = some (node cKeys cChildren) := hsome
    obtain ⟨hilt, hget⟩ := List.getElem?_eq_some_iff.mp hsome'
    have hmem : node cKeys cChildren ∈ cs := List.mem_iff_getElem?.mpr ⟨_, hsome'⟩
    have hcb_child : ChildBounded (node cKeys cChildren) := by
      unfold ChildBounded at hcb; rcases hcb with ⟨_, _, hsub⟩; exact hsub _ hmem
    have hs_child : Sorted (node cKeys cChildren) := by unfold Sorted at hs; exact hs.2 _ hmem
    have ihc := ih hcb_child hs_child
    have hval : insertNonFull t x (node ks cs)
        = node ks (cs.set (findChild ks x) (insertNonFull t x (node cKeys cChildren))) := by
      rw [insertNonFull, if_neg hne]; dsimp only
      split
      · rename_i hcnone; rw [hsome'] at hcnone; exact absurd hcnone (by simp)
      · rename_i c hcsome
        obtain rfl : c = node cKeys cChildren := by
          rw [hsome'] at hcsome; injection hcsome with h; exact h.symm
        dsimp only; rw [if_neg hnfull]
    rw [hval]
    unfold Sorted at hs ⊢
    refine ⟨hs.1, fun c hc => ?_⟩
    rcases List.mem_or_eq_of_mem_set hc with hcs | rfl
    · exact hs.2 c hcs
    · exact ihc
  | case3 ks cs hne i cKeys cChildren hsome hfull median hlt hsome2 ih =>
    intro hcb hs
    have hsome' : cs[findChild ks x]? = some (node cKeys cChildren) := hsome
    obtain ⟨hilt, hget⟩ := List.getElem?_eq_some_iff.mp hsome'
    have hget' : cs.get ⟨findChild ks x, hilt⟩ = node cKeys cChildren := by
      rw [List.get_eq_getElem]; exact hget
    have hmem : node cKeys cChildren ∈ cs := List.mem_iff_getElem?.mpr ⟨_, hsome'⟩
    have hcb_child : ChildBounded (node cKeys cChildren) := by
      unfold ChildBounded at hcb; rcases hcb with ⟨_, _, hsub⟩; exact hsub _ hmem
    have hs_child : Sorted (node cKeys cChildren) := by unfold Sorted at hs; exact hs.2 _ hmem
    have ht1 : t - 1 < cKeys.length := by rw [hfull]; omega
    have hcb_LH : ChildBounded (node (cKeys.take (t - 1)) (cChildren.take t)) := by
      have h := childBounded_take_of_full hcb_child ht1
      rwa [show (t - 1) + 1 = t from by omega] at h
    have ihc := ih hcb_LH (sorted_take (t - 1) t hs_child)
    have hmed : cKeys.getD (t - 1) 0 = cKeys[t - 1] := by
      simp only [List.getD_eq_getElem?_getD, List.getElem?_eq_getElem ht1, Option.getD_some]
    have hval : insertNonFull t x (node ks cs)
        = node (ks.take (findChild ks x) ++ cKeys.getD (t - 1) 0 :: ks.drop (findChild ks x))
            (cs.take (findChild ks x) ++
              [insertNonFull t x (node (cKeys.take (t - 1)) (cChildren.take t)),
               node (cKeys.drop t) (cChildren.drop t)] ++ cs.drop (findChild ks x + 1)) := by
      rw [insertNonFull, if_neg hne]; dsimp only
      split
      · rename_i hcnone; rw [hsome'] at hcnone; exact absurd hcnone (by simp)
      · rename_i c hcsome
        obtain rfl : c = node cKeys cChildren := by
          rw [hsome'] at hcsome; injection hcsome with h; exact h.symm
        dsimp only; rw [if_pos hfull, if_pos hlt]
    have hsplit := splitChild_preserves_sorted t ht ks cs cKeys cChildren (findChild ks x)
      hilt hget' hfull hs hcb
    rw [splitChild_full_eq t ht ks cs (findChild ks x) cKeys cChildren hilt hget' hfull] at hsplit
    rw [hval, hmed]
    unfold Sorted at hsplit ⊢
    refine ⟨hsplit.1, fun c hc => ?_⟩
    rcases List.mem_append.mp hc with h1 | h2
    · rcases List.mem_append.mp h1 with hta | hmid
      · exact hsplit.2 c (List.mem_append_left _ (List.mem_append_left _ hta))
      · simp only [List.mem_cons, List.not_mem_nil, or_false] at hmid
        rcases hmid with rfl | rfl
        · exact ihc
        · exact hsplit.2 _ (List.mem_append_left _ (List.mem_append_right _ (by simp)))
    · exact hsplit.2 c (List.mem_append_right _ h2)
  | case4 ks cs hne i cKeys cChildren hsome hfull median hnlt hsome2 ih =>
    intro hcb hs
    have hsome' : cs[findChild ks x]? = some (node cKeys cChildren) := hsome
    obtain ⟨hilt, hget⟩ := List.getElem?_eq_some_iff.mp hsome'
    have hget' : cs.get ⟨findChild ks x, hilt⟩ = node cKeys cChildren := by
      rw [List.get_eq_getElem]; exact hget
    have hmem : node cKeys cChildren ∈ cs := List.mem_iff_getElem?.mpr ⟨_, hsome'⟩
    have hcb_child : ChildBounded (node cKeys cChildren) := by
      unfold ChildBounded at hcb; rcases hcb with ⟨_, _, hsub⟩; exact hsub _ hmem
    have hs_child : Sorted (node cKeys cChildren) := by unfold Sorted at hs; exact hs.2 _ hmem
    have ht1 : t - 1 < cKeys.length := by rw [hfull]; omega
    have hcb_RH : ChildBounded (node (cKeys.drop t) (cChildren.drop t)) := by
      rcases child_children_len_of_full_cb ht hcb_child hfull with h0 | h2t
      · have hnil : cChildren = [] := by cases cChildren with | nil => rfl | cons a b => simp at h0
        rw [hnil]; simpa using childBounded_node_nil (cKeys.drop t)
      · exact childBounded_drop_of_full hcb_child (by omega) (by rw [h2t]; omega)
    have ihc := ih hcb_RH (sorted_drop t t hs_child)
    have hmed : cKeys.getD (t - 1) 0 = cKeys[t - 1] := by
      simp only [List.getD_eq_getElem?_getD, List.getElem?_eq_getElem ht1, Option.getD_some]
    have hval : insertNonFull t x (node ks cs)
        = node (ks.take (findChild ks x) ++ cKeys.getD (t - 1) 0 :: ks.drop (findChild ks x))
            (cs.take (findChild ks x) ++
              [node (cKeys.take (t - 1)) (cChildren.take t),
               insertNonFull t x (node (cKeys.drop t) (cChildren.drop t))]
              ++ cs.drop (findChild ks x + 1)) := by
      rw [insertNonFull, if_neg hne]; dsimp only
      split
      · rename_i hcnone; rw [hsome'] at hcnone; exact absurd hcnone (by simp)
      · rename_i c hcsome
        obtain rfl : c = node cKeys cChildren := by
          rw [hsome'] at hcsome; injection hcsome with h; exact h.symm
        dsimp only; rw [if_pos hfull, if_neg hnlt]
    have hsplit := splitChild_preserves_sorted t ht ks cs cKeys cChildren (findChild ks x)
      hilt hget' hfull hs hcb
    rw [splitChild_full_eq t ht ks cs (findChild ks x) cKeys cChildren hilt hget' hfull] at hsplit
    rw [hval, hmed]
    unfold Sorted at hsplit ⊢
    refine ⟨hsplit.1, fun c hc => ?_⟩
    rcases List.mem_append.mp hc with h1 | h2
    · rcases List.mem_append.mp h1 with hta | hmid
      · exact hsplit.2 c (List.mem_append_left _ (List.mem_append_left _ hta))
      · simp only [List.mem_cons, List.not_mem_nil, or_false] at hmid
        rcases hmid with rfl | rfl
        · exact hsplit.2 _ (List.mem_append_left _ (List.mem_append_right _ (by simp)))
        · exact ihc
    · exact hsplit.2 c (List.mem_append_right _ h2)

ChildBounded preservation

Membership after insertNonFull (from insertNonFull_keys_perm).


lemma mem_insertNonFull {t x : Nat} (ht : 2 ≤ t) {tr : BTree} (hcb : ChildBounded tr) {y : Nat} :
    y ∈ keysOf (insertNonFull t x tr) ↔ y = x ∨ y ∈ keysOf tr := by
  rw [(insertNonFull_keys_perm t x ht tr hcb).mem_iff, List.mem_append, List.mem_singleton]
  tauto

Replacing child j of a ChildBounded node with c' preserves ChildBounded, provided c' is itself ChildBounded and its keys satisfy the separator bounds at position j.


lemma childBounded_set {ks : List Nat} {cs : List BTree} {j : Nat} {c' : BTree}
    (hcb : ChildBounded (node ks cs)) (hj : j < cs.length) (hc' : ChildBounded c')
    (h_lo : j = 0 ∨ (match ks[j - 1]? with | some lo => ∀ k ∈ keysOf c', lo ≤ k | none => True))
    (h_hi : match ks[j]? with | some hi => ∀ k ∈ keysOf c', k ≤ hi | none => True) :
    ChildBounded (node ks (cs.set j c')) := by
  unfold ChildBounded at hcb ⊢
  obtain ⟨h_rel, h_bounds, h_sub⟩ := hcb
  refine ⟨?_, ?_, ?_⟩
  · have hne0 : cs.length ≠ 0 := by omega
    rcases h_rel with he | he
    · rw [List.isEmpty_iff] at he; rw [he] at hne0; simp at hne0
    · right; rw [List.length_set]; exact he
  · intro m hm
    have hm_cs : m < cs.length := by rw [List.length_set] at hm; exact hm
    by_cases hmj : m = j
    · subst hmj
      have hchild : (cs.set m c').get ⟨m, hm⟩ = c' := by
        rw [List.get_eq_getElem, List.getElem_set_self]
      rw [hchild]; exact ⟨h_lo, h_hi⟩
    · have hchild : (cs.set j c').get ⟨m, hm⟩ = cs.get ⟨m, hm_cs⟩ := by
        rw [List.get_eq_getElem, List.getElem_set_ne (Ne.symm hmj), List.get_eq_getElem]
      rw [hchild]; exact h_bounds m hm_cs
  · intro c hc
    rcases List.mem_or_eq_of_mem_set hc with hcs | rfl
    · exact h_sub c hcs
    · exact hc'

Replacing child j by insertNonFull t x (child j) preserves ChildBounded, provided x lies within the separator bounds at position j.


lemma childBounded_set_insertNonFull (t x : Nat) (ht : 2 ≤ t)
    {ks : List Nat} {cs : List BTree} {j : Nat}
    (hcb : ChildBounded (node ks cs)) (hj : j < cs.length)
    (hc' : ChildBounded (insertNonFull t x (cs.get ⟨j, hj⟩)))
    (hx_lo : j = 0 ∨ ∀ lo, ks[j - 1]? = some lo → lo ≤ x)
    (hx_hi : ∀ hi, ks[j]? = some hi → x ≤ hi) :
    ChildBounded (node ks (cs.set j (insertNonFull t x (cs.get ⟨j, hj⟩)))) := by
  have hcbb := hcb
  unfold ChildBounded at hcbb
  obtain ⟨_, h_bounds, h_sub⟩ := hcbb
  have hcb_child : ChildBounded (cs.get ⟨j, hj⟩) := h_sub _ (List.get_mem _ _)
  have hbounds := h_bounds j hj
  apply childBounded_set hcb hj hc'
  · by_cases hj0 : j = 0
    · exact Or.inl hj0
    · right
      rcases hx_lo with h0 | hxlo
      · exact absurd h0 hj0
      · cases hks : ks[j - 1]? with
        | none => trivial
        | some lo =>
          intro k hk
          rw [mem_insertNonFull ht hcb_child] at hk
          rcases hk with rfl | hk
          · exact hxlo lo hks
          · rcases hbounds.1 with hj0' | hlo_match
            · exact absurd hj0' hj0
            · rw [hks] at hlo_match; exact hlo_match k hk
  · cases hks : ks[j]? with
    | none => trivial
    | some hi =>
      intro k hk
      rw [mem_insertNonFull ht hcb_child] at hk
      rcases hk with rfl | hk
      · exact hx_hi hi hks
      · have hb2 := hbounds.2; rw [hks] at hb2; exact hb2 k hk

insertNonFull preserves ChildBounded (given ChildBounded + Sorted).


lemma insertNonFull_childBounded (t x : Nat) (ht : 2 ≤ t) :
    ∀ tr, ChildBounded tr → Sorted tr → ChildBounded (insertNonFull t x tr) := by
  intro tr
  induction tr using insertNonFull.induct (t := t) (x := x) with
  | case1 ks cs hempty =>
    intro _ _
    have hcsnil : cs = [] := List.isEmpty_iff.mp hempty
    subst hcsnil
    rw [insertNonFull]; simp only [List.isEmpty_nil, if_true]
    exact childBounded_node_nil (sortedInsert x ks)
  | case2 ks cs hne i hnone =>
    intro hcb _
    have hval : insertNonFull t x (node ks cs) = node ks cs := by
      rw [insertNonFull, if_neg hne]; dsimp only
      split
      · rfl
      · rename_i c hcsome
        have hn : cs[findChild ks x]? = none := hnone; rw [hcsome] at hn; simp at hn
    rw [hval]; exact hcb
  | case5 ks cs hne i cKeys cChildren hsome hnfull hsome2 ih =>
    intro hcb hs
    have hsome' : cs[findChild ks x]? = some (node cKeys cChildren) := hsome
    obtain ⟨hilt, hget⟩ := List.getElem?_eq_some_iff.mp hsome'
    have hget' : cs.get ⟨findChild ks x, hilt⟩ = node cKeys cChildren := by
      rw [List.get_eq_getElem]; exact hget
    have hmem : node cKeys cChildren ∈ cs := List.mem_iff_getElem?.mpr ⟨_, hsome'⟩
    have hcb_child : ChildBounded (node cKeys cChildren) := by
      unfold ChildBounded at hcb; rcases hcb with ⟨_, _, hsub⟩; exact hsub _ hmem
    have hs_child : Sorted (node cKeys cChildren) := by unfold Sorted at hs; exact hs.2 _ hmem
    have hpw : List.Pairwise (· ≤ ·) ks := by unfold Sorted at hs; exact hs.1
    have ihc := ih hcb_child hs_child
    have hval : insertNonFull t x (node ks cs)
        = node ks (cs.set (findChild ks x) (insertNonFull t x (node cKeys cChildren))) := by
      rw [insertNonFull, if_neg hne]; dsimp only
      split
      · rename_i hcnone; rw [hsome'] at hcnone; exact absurd hcnone (by simp)
      · rename_i c hcsome
        obtain rfl : c = node cKeys cChildren := by
          rw [hsome'] at hcsome; injection hcsome with h; exact h.symm
        dsimp only; rw [if_neg hnfull]
    rw [hval, ← hget']
    exact childBounded_set_insertNonFull t x ht hcb hilt (by rw [hget']; exact ihc)
      (findChild_x_lo ks x) (findChild_x_hi hpw x)
  | case3 ks cs hne i cKeys cChildren hsome hfull median hlt hsome2 ih =>
    intro hcb hs
    have hsome' : cs[findChild ks x]? = some (node cKeys cChildren) := hsome
    obtain ⟨hilt, hget⟩ := List.getElem?_eq_some_iff.mp hsome'
    have hget' : cs.get ⟨findChild ks x, hilt⟩ = node cKeys cChildren := by
      rw [List.get_eq_getElem]; exact hget
    have hmem : node cKeys cChildren ∈ cs := List.mem_iff_getElem?.mpr ⟨_, hsome'⟩
    have hcb_child : ChildBounded (node cKeys cChildren) := by
      unfold ChildBounded at hcb; rcases hcb with ⟨_, _, hsub⟩; exact hsub _ hmem
    have hs_child : Sorted (node cKeys cChildren) := by unfold Sorted at hs; exact hs.2 _ hmem
    have hpw : List.Pairwise (· ≤ ·) ks := by unfold Sorted at hs; exact hs.1
    have ht1 : t - 1 < cKeys.length := by rw [hfull]; omega
    have hcb_LH : ChildBounded (node (cKeys.take (t - 1)) (cChildren.take t)) := by
      have h := childBounded_take_of_full hcb_child ht1
      rwa [show (t - 1) + 1 = t from by omega] at h
    have ihc := ih hcb_LH (sorted_take (t - 1) t hs_child)
    have hmed : cKeys.getD (t - 1) 0 = cKeys[t - 1] := by
      simp only [List.getD_eq_getElem?_getD, List.getElem?_eq_getElem ht1, Option.getD_some]
    have hie : findChild ks x ≤ ks.length := findChild_le ks x
    have hval : insertNonFull t x (node ks cs)
        = node (ks.take (findChild ks x) ++ cKeys[t - 1] :: ks.drop (findChild ks x))
            (cs.take (findChild ks x) ++
              [insertNonFull t x (node (cKeys.take (t - 1)) (cChildren.take t)),
               node (cKeys.drop t) (cChildren.drop t)] ++ cs.drop (findChild ks x + 1)) := by
      rw [insertNonFull, if_neg hne]; dsimp only
      split
      · rename_i hcnone; rw [hsome'] at hcnone; exact absurd hcnone (by simp)
      · rename_i c hcsome
        obtain rfl : c = node cKeys cChildren := by
          rw [hsome'] at hcsome; injection hcsome with h; exact h.symm
        dsimp only; rw [if_pos hfull, if_pos hlt, hmed]
    have hsplit := splitChild_preserves_childBounded t ht ks cs cKeys cChildren
      (findChild ks x) hilt hget' hfull hcb hs
    rw [splitChild_full_eq t ht ks cs (findChild ks x) cKeys cChildren hilt hget' hfull] at hsplit
    have hj : findChild ks x < (cs.take (findChild ks x) ++
        [node (cKeys.take (t - 1)) (cChildren.take t), node (cKeys.drop t) (cChildren.drop t)]
        ++ cs.drop (findChild ks x + 1)).length := by
      simp only [List.length_append, List.length_take, List.length_cons, List.length_nil,
        List.length_drop]; omega
    have hAlen : (cs.take (findChild ks x)).length = findChild ks x := by
      rw [List.length_take]; omega
    have hlt_AB : findChild ks x < (cs.take (findChild ks x) ++
        [node (cKeys.take (t - 1)) (cChildren.take t), node (cKeys.drop t) (cChildren.drop t)]).length := by
      rw [List.length_append, hAlen]; simp
    have hget_LH : (cs.take (findChild ks x) ++
        [node (cKeys.take (t - 1)) (cChildren.take t), node (cKeys.drop t) (cChildren.drop t)]
        ++ cs.drop (findChild ks x + 1)).get ⟨findChild ks x, hj⟩
        = node (cKeys.take (t - 1)) (cChildren.take t) := by
      simp only [List.get_eq_getElem]
      rw [List.getElem_append_left hlt_AB, List.getElem_append_right (le_of_eq hAlen)]
      simp [hAlen]
    have hx_hi : ∀ hi, (ks.take (findChild ks x) ++ cKeys[t - 1] :: ks.drop (findChild ks x))[findChild ks x]? = some hi → x ≤ hi := by
      intro hi hhi
      rw [List.getElem?_append_right (by rw [List.length_take]; omega), List.length_take,
          Nat.min_eq_left hie, Nat.sub_self] at hhi
      simp only [List.getElem?_cons_zero, Option.some.injEq] at hhi
      subst hhi; rw [← hmed]; exact le_of_lt hlt
    have hx_lo : findChild ks x = 0 ∨ ∀ lo,
        (ks.take (findChild ks x) ++ cKeys[t - 1] :: ks.drop (findChild ks x))[findChild ks x - 1]? = some lo → lo ≤ x := by
      rcases Nat.eq_zero_or_pos (findChild ks x) with h0 | hpos
      · exact Or.inl h0
      · right; intro lo hlo
        rw [List.getElem?_append_left (by rw [List.length_take, Nat.min_eq_left hie]; omega),
            List.getElem?_take_of_lt (by omega)] at hlo
        have hmem2 : lo ∈ ks.take (findChild ks x) := by
          rw [List.mem_iff_getElem?]
          exact ⟨findChild ks x - 1, by rw [List.getElem?_take_of_lt (by omega)]; exact hlo⟩
        exact findChild_take_le x ks lo hmem2
    have hres := childBounded_set_insertNonFull t x ht hsplit hj
      (by rw [hget_LH]; exact ihc) hx_lo hx_hi
    rw [hget_LH] at hres
    rw [hval]
    rw [show cs.take (findChild ks x) ++
          [insertNonFull t x (node (cKeys.take (t - 1)) (cChildren.take t)),
           node (cKeys.drop t) (cChildren.drop t)] ++ cs.drop (findChild ks x + 1)
        = (cs.take (findChild ks x) ++
          [node (cKeys.take (t - 1)) (cChildren.take t), node (cKeys.drop t) (cChildren.drop t)]
          ++ cs.drop (findChild ks x + 1)).set (findChild ks x)
            (insertNonFull t x (node (cKeys.take (t - 1)) (cChildren.take t))) from by
        rw [List.set_append_left _ _ (by rw [List.length_append, hAlen]; simp),
            List.set_append_right _ _ (by rw [hAlen]), hAlen, Nat.sub_self]; rfl]
    exact hres
  | case4 ks cs hne i cKeys cChildren hsome hfull median hnlt hsome2 ih =>
    intro hcb hs
    have hsome' : cs[findChild ks x]? = some (node cKeys cChildren) := hsome
    obtain ⟨hilt, hget⟩ := List.getElem?_eq_some_iff.mp hsome'
    have hget' : cs.get ⟨findChild ks x, hilt⟩ = node cKeys cChildren := by
      rw [List.get_eq_getElem]; exact hget
    have hmem : node cKeys cChildren ∈ cs := List.mem_iff_getElem?.mpr ⟨_, hsome'⟩
    have hcb_child : ChildBounded (node cKeys cChildren) := by
      unfold ChildBounded at hcb; rcases hcb with ⟨_, _, hsub⟩; exact hsub _ hmem
    have hs_child : Sorted (node cKeys cChildren) := by unfold Sorted at hs; exact hs.2 _ hmem
    have hpw : List.Pairwise (· ≤ ·) ks := by unfold Sorted at hs; exact hs.1
    have ht1 : t - 1 < cKeys.length := by rw [hfull]; omega
    have hcb_RH : ChildBounded (node (cKeys.drop t) (cChildren.drop t)) := by
      rcases child_children_len_of_full_cb ht hcb_child hfull with h0 | h2t
      · have hnil : cChildren = [] := by cases cChildren with | nil => rfl | cons a b => simp at h0
        rw [hnil]; simpa using childBounded_node_nil (cKeys.drop t)
      · exact childBounded_drop_of_full hcb_child (by omega) (by rw [h2t]; omega)
    have ihc := ih hcb_RH (sorted_drop t t hs_child)
    have hmed : cKeys.getD (t - 1) 0 = cKeys[t - 1] := by
      simp only [List.getD_eq_getElem?_getD, List.getElem?_eq_getElem ht1, Option.getD_some]
    have hie : findChild ks x ≤ ks.length := findChild_le ks x
    have hval : insertNonFull t x (node ks cs)
        = node (ks.take (findChild ks x) ++ cKeys[t - 1] :: ks.drop (findChild ks x))
            (cs.take (findChild ks x) ++
              [node (cKeys.take (t - 1)) (cChildren.take t),
               insertNonFull t x (node (cKeys.drop t) (cChildren.drop t))]
              ++ cs.drop (findChild ks x + 1)) := by
      rw [insertNonFull, if_neg hne]; dsimp only
      split
      · rename_i hcnone; rw [hsome'] at hcnone; exact absurd hcnone (by simp)
      · rename_i c hcsome
        obtain rfl : c = node cKeys cChildren := by
          rw [hsome'] at hcsome; injection hcsome with h; exact h.symm
        dsimp only; rw [if_pos hfull, if_neg hnlt, hmed]
    have hsplit := splitChild_preserves_childBounded t ht ks cs cKeys cChildren
      (findChild ks x) hilt hget' hfull hcb hs
    rw [splitChild_full_eq t ht ks cs (findChild ks x) cKeys cChildren hilt hget' hfull] at hsplit
    have hj : findChild ks x + 1 < (cs.take (findChild ks x) ++
        [node (cKeys.take (t - 1)) (cChildren.take t), node (cKeys.drop t) (cChildren.drop t)]
        ++ cs.drop (findChild ks x + 1)).length := by
      simp only [List.length_append, List.length_take, List.length_cons, List.length_nil,
        List.length_drop]; omega
    have hAlen : (cs.take (findChild ks x)).length = findChild ks x := by
      rw [List.length_take]; omega
    have hlt_AB : findChild ks x + 1 < (cs.take (findChild ks x) ++
        [node (cKeys.take (t - 1)) (cChildren.take t), node (cKeys.drop t) (cChildren.drop t)]).length := by
      rw [List.length_append, hAlen]; simp
    have hget_RH : (cs.take (findChild ks x) ++
        [node (cKeys.take (t - 1)) (cChildren.take t), node (cKeys.drop t) (cChildren.drop t)]
        ++ cs.drop (findChild ks x + 1)).get ⟨findChild ks x + 1, hj⟩
        = node (cKeys.drop t) (cChildren.drop t) := by
      simp only [List.get_eq_getElem]
      rw [List.getElem_append_left hlt_AB,
          List.getElem_append_right (by rw [hAlen]; omega)]
      simp [hAlen, show findChild ks x + 1 - findChild ks x = 1 from by omega]
    have hx_hi : ∀ hi, (ks.take (findChild ks x) ++ cKeys[t - 1] :: ks.drop (findChild ks x))[findChild ks x + 1]? = some hi → x ≤ hi := by
      intro hi hhi
      rw [List.getElem?_append_right (by rw [List.length_take]; omega), List.length_take,
          Nat.min_eq_left hie] at hhi
      rw [show findChild ks x + 1 - findChild ks x = 0 + 1 from by omega,
          List.getElem?_cons_succ, List.getElem?_drop] at hhi
      have hkeq : findChild ks x + (0) = findChild ks x := by omega
      rw [hkeq] at hhi
      exact findChild_x_hi hpw x hi hhi
    have hx_lo : findChild ks x + 1 = 0 ∨ ∀ lo,
        (ks.take (findChild ks x) ++ cKeys[t - 1] :: ks.drop (findChild ks x))[findChild ks x + 1 - 1]? = some lo → lo ≤ x := by
      right; intro lo hlo
      rw [show findChild ks x + 1 - 1 = findChild ks x from by omega,
          List.getElem?_append_right (by rw [List.length_take]; omega), List.length_take,
          Nat.min_eq_left hie, Nat.sub_self] at hlo
      simp only [List.getElem?_cons_zero, Option.some.injEq] at hlo
      subst hlo; rw [← hmed]; exact not_lt.mp hnlt
    have hres := childBounded_set_insertNonFull t x ht hsplit hj
      (by rw [hget_RH]; exact ihc) hx_lo hx_hi
    rw [hget_RH] at hres
    rw [hval]
    rw [show cs.take (findChild ks x) ++
          [node (cKeys.take (t - 1)) (cChildren.take t),
           insertNonFull t x (node (cKeys.drop t) (cChildren.drop t))] ++ cs.drop (findChild ks x + 1)
        = (cs.take (findChild ks x) ++
          [node (cKeys.take (t - 1)) (cChildren.take t), node (cKeys.drop t) (cChildren.drop t)]
          ++ cs.drop (findChild ks x + 1)).set (findChild ks x + 1)
            (insertNonFull t x (node (cKeys.drop t) (cChildren.drop t))) from by
        rw [List.set_append_left _ _ (by rw [List.length_append, hAlen]; simp),
            List.set_append_right _ _ (by rw [hAlen]; omega), hAlen,
            show findChild ks x + 1 - findChild ks x = 1 from by omega]; rfl]
    exact hres

Occupancy preservation

The left split half is Occupancy-valid as a non-root node.


lemma occupancy_left_half (t : Nat) (ht : 2 ≤ t) {cKeys : List Nat} {cChildren : List BTree}
    (hocc : Occupancy t false (node cKeys cChildren)) (hcb : ChildBounded (node cKeys cChildren))
    (hfull : cKeys.length = 2 * t - 1) :
    Occupancy t false (node (cKeys.take (t - 1)) (cChildren.take t)) := by
  have hlen := child_children_len_of_full_cb ht hcb hfull
  have hkl : (cKeys.take (t - 1)).length = t - 1 := by rw [List.length_take, hfull]; omega
  unfold Occupancy at hocc ⊢
  simp only [Bool.false_eq_true, if_false] at hocc ⊢
  refine ⟨?_, ?_, ?_, ?_⟩
  · show t - 1 ≤ (cKeys.take (t - 1)).length; omega
  · show (cKeys.take (t - 1)).length ≤ 2 * t - 1; omega
  · rcases hlen with h0 | h2t
    · left
      have hnil : cChildren = [] := by cases cChildren with | nil => rfl | cons a b => simp at h0
      rw [hnil]; simp
    · right; rw [List.length_take, h2t]; constructor <;> omega
  · intro child hchild
    exact hocc.2.2.2 child ((List.take_subset t cChildren) hchild)

The right split half is Occupancy-valid as a non-root node.


lemma occupancy_right_half (t : Nat) (ht : 2 ≤ t) {cKeys : List Nat} {cChildren : List BTree}
    (hocc : Occupancy t false (node cKeys cChildren)) (hcb : ChildBounded (node cKeys cChildren))
    (hfull : cKeys.length = 2 * t - 1) :
    Occupancy t false (node (cKeys.drop t) (cChildren.drop t)) := by
  have hlen := child_children_len_of_full_cb ht hcb hfull
  have hkl : (cKeys.drop t).length = t - 1 := by rw [List.length_drop, hfull]; omega
  unfold Occupancy at hocc ⊢
  simp only [Bool.false_eq_true, if_false] at hocc ⊢
  refine ⟨?_, ?_, ?_, ?_⟩
  · show t - 1 ≤ (cKeys.drop t).length; omega
  · show (cKeys.drop t).length ≤ 2 * t - 1; omega
  · rcases hlen with h0 | h2t
    · left
      have hnil : cChildren = [] := by cases cChildren with | nil => rfl | cons a b => simp at h0
      rw [hnil]; simp
    · right; rw [List.length_drop, h2t]; constructor <;> omega
  · intro child hchild
    exact hocc.2.2.2 child ((List.drop_subset t cChildren) hchild)

The number of keys at the root node (used for the non-full precondition).

def rootKeyCount : BTree → Nat
  | node ks _ => ks.length

Top-level `B-TREE-INSERT` operations

CLRS B-TREE-INSERT splits a full root by first installing it as the sole child of a fresh empty root, then applying B-TREE-SPLIT-CHILD at index 0.

def splitRoot (t : Nat) (tr : BTree) : BTree :=
  splitChild t (node [] [tr]) 0

The executable top-level CLRS insertion step: split a full root before descending with B-TREE-INSERT-NONFULL; otherwise descend directly.

def insertRoot (t x : Nat) (tr : BTree) : BTree :=
  if rootKeyCount tr = 2 * t - 1 then
    insertNonFull t x (splitRoot t tr)
  else
    insertNonFull t x tr

Expanding splitRoot on a full root exposes the promoted median and the two CLRS split halves.


lemma splitRoot_full_eq
    (t : Nat) (ht : 2 ≤ t) (ks : List Nat) (cs : List BTree)
    (hfull : ks.length = 2 * t - 1) :
    splitRoot t (node ks cs) =
      node [ks[t - 1]'(by omega)]
        [node (ks.take (t - 1)) (cs.take t),
         node (ks.drop t) (cs.drop t)] := by
  have h_lt : 0 < ([node ks cs] : List BTree).length := by simp
  have hchild_eq :
      ([node ks cs] : List BTree).get ⟨0, h_lt⟩ = node ks cs := by
    simp
  unfold splitRoot
  simpa using
    (splitChild_full_eq t ht [] [node ks cs] 0 ks cs h_lt hchild_eq hfull)

Splitting a full root only redistributes its keys: the flattened key list is a permutation of the original tree's flattened key list.


theorem splitRoot_keys_perm
    (t : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hfull : rootKeyCount tr = 2 * t - 1) :
    (keysOf (splitRoot t tr)).Perm (keysOf tr) := by
  cases tr with
  | node ks cs =>
      change ks.length = 2 * t - 1 at hfull
      have h_lt : 0 < ([node ks cs] : List BTree).length := by simp
      have hchild_eq :
          ([node ks cs] : List BTree).get ⟨0, h_lt⟩ = node ks cs := by
        simp
      unfold splitRoot
      have hperm :=
        splitChild_keys_perm t ht [] [node ks cs] ks cs 0 h_lt hchild_eq hfull
      simpa only [keysOf, List.nil_append, List.flatMap_cons, List.flatMap_nil,
        List.append_nil] using hperm

Splitting a full CLRS root creates a fresh root containing exactly the promoted median key.


lemma splitRoot_rootKeyCount
    (t : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hfull : rootKeyCount tr = 2 * t - 1) :
    rootKeyCount (splitRoot t tr) = 1 := by
  cases tr with
  | node ks cs =>
      change ks.length = 2 * t - 1 at hfull
      rw [splitRoot_full_eq t ht ks cs hfull]
      rfl

The fresh one-key root produced by splitting a full root satisfies the non-full precondition required by B-TREE-INSERT-NONFULL.


lemma splitRoot_nonFull
    (t : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hfull : rootKeyCount tr = 2 * t - 1) :
    rootKeyCount (splitRoot t tr) < 2 * t - 1 := by
  rw [splitRoot_rootKeyCount t ht hfull]
  omega

A full old root satisfies the ordinary non-root occupancy bounds when it becomes the sole child of the transient empty root.

lemma occupancy_false_of_full_root
    (t : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hcb : ChildBounded tr)
    (hocc : Occupancy t true tr)
    (hfull : rootKeyCount tr = 2 * t - 1) :
    Occupancy t false tr := by
  cases tr with
  | node ks cs =>
      change ks.length = 2 * t - 1 at hfull
      have hlen := child_children_len_of_full_cb ht hcb hfull
      unfold Occupancy at hocc ⊢
      simp only [if_true] at hocc
      simp only [Bool.false_eq_true, if_false]
      refine ⟨?_, hocc.2.1, ?_, hocc.2.2.2⟩
      · omega
      · rcases hlen with h0 | h2t
        · left
          cases cs with
          | nil => simp
          | cons c cs => simp at h0
        · right
          constructor <;> omega

Sorted component for the transient empty root used by splitRoot.

private lemma sorted_transient_root {tr : BTree} (hs : Sorted tr) :
    Sorted (node [] [tr]) := by
  unfold Sorted
  refine ⟨by simp, ?_⟩
  intro child hchild
  simp only [List.mem_singleton] at hchild
  subst child
  exact hs

ChildBounded component for the transient empty root used by splitRoot.


private lemma childBounded_transient_root {tr : BTree} (hcb : ChildBounded tr) :
    ChildBounded (node [] [tr]) := by
  unfold ChildBounded
  refine ⟨?_, ?_, ?_⟩
  · right
    simp
  · intro i hi
    have hi0 : i = 0 := by
      simp at hi
      omega
    subst i
    simp
  · intro child hchild
    simp only [List.mem_singleton] at hchild
    subst child
    exact hcb

SameDepth component for the transient empty root used by splitRoot.

private lemma sameDepth_transient_root {tr : BTree} (hsd : SameDepth tr) :
    SameDepth (node [] [tr]) := by
  exact SameDepth.internal [] tr [] (by simp) hsd (by simp)

Splitting a full root establishes root occupancy directly, without requiring the transient empty wrapper itself to satisfy root occupancy.


lemma splitRoot_occupancy
    (t : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hcb : ChildBounded tr)
    (hocc : Occupancy t true tr)
    (hfull : rootKeyCount tr = 2 * t - 1) :
    Occupancy t true (splitRoot t tr) := by
  cases tr with
  | node ks cs =>
      change ks.length = 2 * t - 1 at hfull
      have hocc_child : Occupancy t false (node ks cs) :=
        occupancy_false_of_full_root t ht hcb hocc hfull
      have hocc_left :=
        occupancy_left_half t ht hocc_child hcb hfull
      have hocc_right :=
        occupancy_right_half t ht hocc_child hcb hfull
      rw [splitRoot_full_eq t ht ks cs hfull]
      unfold Occupancy
      simp only [if_true, List.length_cons, List.length_nil, Nat.zero_add,
        List.isEmpty_cons, Bool.false_eq_true, and_false, if_false, false_or]
      refine ⟨?_, ?_, ?_, ?_⟩
      · omega
      · omega
      · constructor <;> omega
      · intro child hchild
        simp only [List.mem_cons, List.not_mem_nil, or_false] at hchild
        rcases hchild with rfl | rfl
        · exact hocc_left
        · exact hocc_right

Splitting a full well-formed root preserves every structural B-tree invariant.


theorem splitRoot_wellFormed
    (t : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hwf : WellFormed t tr)
    (hfull : rootKeyCount tr = 2 * t - 1) :
    WellFormed t (splitRoot t tr) := by
  obtain ⟨hs, hcb, hocc, hsd⟩ := hwf
  cases tr with
  | node ks cs =>
      change ks.length = 2 * t - 1 at hfull
      have h_lt : 0 < ([node ks cs] : List BTree).length := by simp
      have hchild_eq :
          ([node ks cs] : List BTree).get ⟨0, h_lt⟩ = node ks cs := by
        simp
      have hchildren : cs = [] ∨ t < cs.length := by
        rcases child_children_len_of_full_cb ht hcb hfull with h0 | h2t
        · left
          exact List.eq_nil_of_length_eq_zero h0
        · right
          omega
      have hs_wrapper := sorted_transient_root hs
      have hcb_wrapper := childBounded_transient_root hcb
      have hsd_wrapper := sameDepth_transient_root hsd
      have hs_split :=
        splitChild_preserves_sorted t ht [] [node ks cs] ks cs 0
          h_lt hchild_eq hfull hs_wrapper hcb_wrapper
      have hcb_split :=
        splitChild_preserves_childBounded t ht [] [node ks cs] ks cs 0
          h_lt hchild_eq hfull hcb_wrapper hs_wrapper
      have hsd_split :=
        splitChild_preserves_sameDepth t ht [] [node ks cs] ks cs 0
          h_lt hchild_eq hfull hchildren hsd_wrapper
      exact ⟨by simpa only [splitRoot] using hs_split,
        by simpa only [splitRoot] using hcb_split,
        splitRoot_occupancy t ht hcb hocc hfull,
        by simpa only [splitRoot] using hsd_split⟩

Splitting a full root adds exactly one level to the tree.


theorem splitRoot_height
    (t : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hwf : WellFormed t tr)
    (hfull : rootKeyCount tr = 2 * t - 1) :
    heightOf (splitRoot t tr) = heightOf tr + 1 := by
  obtain ⟨_, hcb, _, hsd⟩ := hwf
  cases tr with
  | node ks cs =>
      change ks.length = 2 * t - 1 at hfull
      have hchildren : cs = [] ∨ t < cs.length := by
        rcases child_children_len_of_full_cb ht hcb hfull with h0 | h2t
        · left
          exact List.eq_nil_of_length_eq_zero h0
        · right
          omega
      have hparts :=
        heightOf_split_parts_eq ks cs t hsd (by omega) hchildren
      have hleft :
          heightOf (node (ks.take (t - 1)) (cs.take t)) =
            heightOf (node ks cs) := by
        simpa using hparts.1
      have hright :
          heightOf (node (ks.drop t) (cs.drop t)) =
            heightOf (node ks cs) := by
        simpa [List.drop_drop, show (t - 1) + 1 = t from by omega] using hparts.2
      rw [splitRoot_full_eq t ht ks cs hfull]
      have huniform :
          ∀ c ∈ [node (ks.drop t) (cs.drop t)],
            heightOf c = heightOf (node (ks.take (t - 1)) (cs.take t)) := by
        intro c hc
        simp only [List.mem_singleton] at hc
        subst c
        exact hright.trans hleft.symm
      rw [heightOf_uniform_children huniform, hleft]
      omega

Replacing child j with an Occupancy-valid (non-root) subtree preserves Occupancy.


lemma occupancy_set {t : Nat} {b : Bool} {ks : List Nat} {cs : List BTree} {j : Nat} {c' : BTree}
    (hocc : Occupancy t b (node ks cs)) (hj : j < cs.length) (hc' : Occupancy t false c') :
    Occupancy t b (node ks (cs.set j c')) := by
  have hemp : (cs.set j c').isEmpty = cs.isEmpty := by
    cases cs with
    | nil => simp at hj
    | cons a as => cases j <;> simp
  have hlen : (cs.set j c').length = cs.length := List.length_set
  unfold Occupancy at hocc ⊢
  rw [hemp, hlen]
  refine ⟨hocc.1, hocc.2.1, hocc.2.2.1, ?_⟩
  intro c hc
  rcases List.mem_or_eq_of_mem_set hc with hcs | rfl
  · exact hocc.2.2.2 c hcs
  · exact hc'

insertNonFull preserves Occupancy (given the node is ChildBounded and non-full). Works for both the root and non-root occupancy flags.


lemma insertNonFull_occupancy (t x : Nat) (ht : 2 ≤ t) :
    ∀ tr (b : Bool), ChildBounded tr → Occupancy t b tr → rootKeyCount tr < 2 * t - 1 →
      Occupancy t b (insertNonFull t x tr) := by
  intro tr
  induction tr using insertNonFull.induct (t := t) (x := x) with
  | case1 ks cs hempty =>
    intro b hcb hocc hnf
    have hcsnil : cs = [] := List.isEmpty_iff.mp hempty
    subst hcsnil
    have hnf' : ks.length < 2 * t - 1 := hnf
    rw [insertNonFull]; simp only [List.isEmpty_nil, if_true]
    have hlen : (sortedInsert x ks).length = ks.length + 1 := by
      rw [(sortedInsert_perm x ks).length_eq]; simp
    unfold Occupancy at hocc ⊢
    refine ⟨?_, ?_, Or.inl (by simp), by intro c hc; simp at hc⟩
    · cases b
      · simp only [Bool.false_eq_true, if_false] at hocc ⊢; omega
      · simp only [if_true]; rw [hlen]; split <;> omega
    · rw [hlen]; omega
  | case2 ks cs hne i hnone =>
    intro b hcb hocc _
    have hval : insertNonFull t x (node ks cs) = node ks cs := by
      rw [insertNonFull, if_neg hne]; dsimp only
      split
      · rfl
      · rename_i c hcsome
        have hn : cs[findChild ks x]? = none := hnone; rw [hcsome] at hn; simp at hn
    rw [hval]; exact hocc
  | case5 ks cs hne i cKeys cChildren hsome hnfull hsome2 ih =>
    intro b hcb hocc hnf
    have hsome' : cs[findChild ks x]? = some (node cKeys cChildren) := hsome
    obtain ⟨hilt, hget⟩ := List.getElem?_eq_some_iff.mp hsome'
    have hmem : node cKeys cChildren ∈ cs := List.mem_iff_getElem?.mpr ⟨_, hsome'⟩
    have hcb_child : ChildBounded (node cKeys cChildren) := by
      unfold ChildBounded at hcb; rcases hcb with ⟨_, _, hsub⟩; exact hsub _ hmem
    have hocc_child : Occupancy t false (node cKeys cChildren) := by
      unfold Occupancy at hocc; exact hocc.2.2.2 _ hmem
    have hnf_child : rootKeyCount (node cKeys cChildren) < 2 * t - 1 := by
      show cKeys.length < 2 * t - 1
      have : cKeys.length ≤ 2 * t - 1 := by unfold Occupancy at hocc_child; exact hocc_child.2.1
      omega
    have ihc := ih false hcb_child hocc_child hnf_child
    have hval : insertNonFull t x (node ks cs)
        = node ks (cs.set (findChild ks x) (insertNonFull t x (node cKeys cChildren))) := by
      rw [insertNonFull, if_neg hne]; dsimp only
      split
      · rename_i hcnone; rw [hsome'] at hcnone; exact absurd hcnone (by simp)
      · rename_i c hcsome
        obtain rfl : c = node cKeys cChildren := by
          rw [hsome'] at hcsome; injection hcsome with h; exact h.symm
        dsimp only; rw [if_neg hnfull]
    rw [hval]
    exact occupancy_set hocc hilt ihc
  | case3 ks cs hne i cKeys cChildren hsome hfull median hlt hsome2 ih =>
    intro b hcb hocc hnf
    have hsome' : cs[findChild ks x]? = some (node cKeys cChildren) := hsome
    obtain ⟨hilt, hget⟩ := List.getElem?_eq_some_iff.mp hsome'
    have hmem : node cKeys cChildren ∈ cs := List.mem_iff_getElem?.mpr ⟨_, hsome'⟩
    have hcb_u := hcb; unfold ChildBounded at hcb_u
    have hocc_u := hocc; unfold Occupancy at hocc_u
    obtain ⟨hocc_lo, hocc_up, hocc_ch, hocc_rec⟩ := hocc_u
    have hcb_child : ChildBounded (node cKeys cChildren) := hcb_u.2.2 _ hmem
    have hocc_child : Occupancy t false (node cKeys cChildren) := hocc_rec _ hmem
    have ht1 : t - 1 < cKeys.length := by rw [hfull]; omega
    have hcb_LH : ChildBounded (node (cKeys.take (t - 1)) (cChildren.take t)) := by
      have h := childBounded_take_of_full hcb_child ht1
      rwa [show (t - 1) + 1 = t from by omega] at h
    have hocc_RH := occupancy_right_half t ht hocc_child hcb_child hfull
    have hnf_LH : rootKeyCount (node (cKeys.take (t - 1)) (cChildren.take t)) < 2 * t - 1 := by
      show (cKeys.take (t - 1)).length < 2 * t - 1; rw [List.length_take]; omega
    have ihc := ih false hcb_LH (occupancy_left_half t ht hocc_child hcb_child hfull) hnf_LH
    have hnf' : ks.length < 2 * t - 1 := hnf
    have hmed : cKeys.getD (t - 1) 0 = cKeys[t - 1] := by
      simp only [List.getD_eq_getElem?_getD, List.getElem?_eq_getElem ht1, Option.getD_some]
    have hcs_eq : cs.length = ks.length + 1 := by
      rcases hcb_u.1 with he | heq
      · rw [List.isEmpty_iff] at he; rw [he] at hilt; simp at hilt
      · exact heq
    have hval : insertNonFull t x (node ks cs)
        = node (ks.take (findChild ks x) ++ cKeys[t - 1] :: ks.drop (findChild ks x))
            (cs.take (findChild ks x) ++
              [insertNonFull t x (node (cKeys.take (t - 1)) (cChildren.take t)),
               node (cKeys.drop t) (cChildren.drop t)] ++ cs.drop (findChild ks x + 1)) := by
      rw [insertNonFull, if_neg hne]; dsimp only
      split
      · rename_i hcnone; rw [hsome'] at hcnone; exact absurd hcnone (by simp)
      · rename_i c hcsome
        obtain rfl : c = node cKeys cChildren := by
          rw [hsome'] at hcsome; injection hcsome with h; exact h.symm
        dsimp only; rw [if_pos hfull, if_pos hlt, hmed]
    rw [hval]
    have hNKlen : (ks.take (findChild ks x) ++ cKeys[t - 1] :: ks.drop (findChild ks x)).length
        = ks.length + 1 := by
      rw [List.length_append, List.length_cons, List.length_take, List.length_drop]
      have := findChild_le ks x; omega
    have hMYlen : (cs.take (findChild ks x) ++
        [insertNonFull t x (node (cKeys.take (t - 1)) (cChildren.take t)),
         node (cKeys.drop t) (cChildren.drop t)] ++ cs.drop (findChild ks x + 1)).length
        = cs.length + 1 := by
      simp only [List.length_append, List.length_cons, List.length_nil, List.length_take,
        List.length_drop]; omega
    unfold Occupancy
    refine ⟨?_, ?_, ?_, ?_⟩
    · cases b
      · simp only [Bool.false_eq_true, if_false] at hocc_lo ⊢
        rw [hNKlen]; omega
      · simp only [if_true]; rw [hNKlen]; split <;> omega
    · rw [hNKlen]; omega
    · right; rw [hMYlen]
      rcases hocc_ch with he | hb
      · rw [List.isEmpty_iff] at he; rw [he] at hilt; simp at hilt
      · omega
    · intro c hc
      rcases List.mem_append.mp hc with h1 | h2
      · rcases List.mem_append.mp h1 with hta | hmid
        · exact hocc_rec c ((List.take_subset _ _) hta)
        · simp only [List.mem_cons, List.not_mem_nil, or_false] at hmid
          rcases hmid with rfl | rfl
          · exact ihc
          · exact hocc_RH
      · exact hocc_rec c ((List.drop_subset _ _) h2)
  | case4 ks cs hne i cKeys cChildren hsome hfull median hnlt hsome2 ih =>
    intro b hcb hocc hnf
    have hsome' : cs[findChild ks x]? = some (node cKeys cChildren) := hsome
    obtain ⟨hilt, hget⟩ := List.getElem?_eq_some_iff.mp hsome'
    have hmem : node cKeys cChildren ∈ cs := List.mem_iff_getElem?.mpr ⟨_, hsome'⟩
    have hcb_u := hcb; unfold ChildBounded at hcb_u
    have hocc_u := hocc; unfold Occupancy at hocc_u
    obtain ⟨hocc_lo, hocc_up, hocc_ch, hocc_rec⟩ := hocc_u
    have hcb_child : ChildBounded (node cKeys cChildren) := hcb_u.2.2 _ hmem
    have hocc_child : Occupancy t false (node cKeys cChildren) := hocc_rec _ hmem
    have ht1 : t - 1 < cKeys.length := by rw [hfull]; omega
    have hcb_RH : ChildBounded (node (cKeys.drop t) (cChildren.drop t)) := by
      rcases child_children_len_of_full_cb ht hcb_child hfull with h0 | h2t
      · have hnil : cChildren = [] := by cases cChildren with | nil => rfl | cons a b => simp at h0
        rw [hnil]; simpa using childBounded_node_nil (cKeys.drop t)
      · exact childBounded_drop_of_full hcb_child (by omega) (by rw [h2t]; omega)
    have hocc_LH := occupancy_left_half t ht hocc_child hcb_child hfull
    have hnf_RH : rootKeyCount (node (cKeys.drop t) (cChildren.drop t)) < 2 * t - 1 := by
      show (cKeys.drop t).length < 2 * t - 1; rw [List.length_drop]; omega
    have ihc := ih false hcb_RH (occupancy_right_half t ht hocc_child hcb_child hfull) hnf_RH
    have hnf' : ks.length < 2 * t - 1 := hnf
    have hmed : cKeys.getD (t - 1) 0 = cKeys[t - 1] := by
      simp only [List.getD_eq_getElem?_getD, List.getElem?_eq_getElem ht1, Option.getD_some]
    have hcs_eq : cs.length = ks.length + 1 := by
      rcases hcb_u.1 with he | heq
      · rw [List.isEmpty_iff] at he; rw [he] at hilt; simp at hilt
      · exact heq
    have hval : insertNonFull t x (node ks cs)
        = node (ks.take (findChild ks x) ++ cKeys[t - 1] :: ks.drop (findChild ks x))
            (cs.take (findChild ks x) ++
              [node (cKeys.take (t - 1)) (cChildren.take t),
               insertNonFull t x (node (cKeys.drop t) (cChildren.drop t))]
              ++ cs.drop (findChild ks x + 1)) := by
      rw [insertNonFull, if_neg hne]; dsimp only
      split
      · rename_i hcnone; rw [hsome'] at hcnone; exact absurd hcnone (by simp)
      · rename_i c hcsome
        obtain rfl : c = node cKeys cChildren := by
          rw [hsome'] at hcsome; injection hcsome with h; exact h.symm
        dsimp only; rw [if_pos hfull, if_neg hnlt, hmed]
    rw [hval]
    have hNKlen : (ks.take (findChild ks x) ++ cKeys[t - 1] :: ks.drop (findChild ks x)).length
        = ks.length + 1 := by
      rw [List.length_append, List.length_cons, List.length_take, List.length_drop]
      have := findChild_le ks x; omega
    have hMYlen : (cs.take (findChild ks x) ++
        [node (cKeys.take (t - 1)) (cChildren.take t),
         insertNonFull t x (node (cKeys.drop t) (cChildren.drop t))] ++ cs.drop (findChild ks x + 1)).length
        = cs.length + 1 := by
      simp only [List.length_append, List.length_cons, List.length_nil, List.length_take,
        List.length_drop]; omega
    unfold Occupancy
    refine ⟨?_, ?_, ?_, ?_⟩
    · cases b
      · simp only [Bool.false_eq_true, if_false] at hocc_lo ⊢
        rw [hNKlen]; omega
      · simp only [if_true]; rw [hNKlen]; split <;> omega
    · rw [hNKlen]; omega
    · right; rw [hMYlen]
      rcases hocc_ch with he | hb
      · rw [List.isEmpty_iff] at he; rw [he] at hilt; simp at hilt
      · omega
    · intro c hc
      rcases List.mem_append.mp hc with h1 | h2
      · rcases List.mem_append.mp h1 with hta | hmid
        · exact hocc_rec c ((List.take_subset _ _) hta)
        · simp only [List.mem_cons, List.not_mem_nil, or_false] at hmid
          rcases hmid with rfl | rfl
          · exact hocc_LH
          · exact ihc
      · exact hocc_rec c ((List.drop_subset _ _) h2)

B-TREE-INSERT-NONFULL preserves WellFormed. Inserting into a non-full, well-formed B-tree yields a well-formed B-tree. Assembles the four invariant-preservation lemmas.

theorem insertNonFull_wellFormed (t x : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hwf : WellFormed t tr) (hnf : rootKeyCount tr < 2 * t - 1) :
    WellFormed t (insertNonFull t x tr) := by
  obtain ⟨hs, hcb, hocc, hsd⟩ := hwf
  exact ⟨insertNonFull_sorted t x ht tr hcb hs,
         insertNonFull_childBounded t x ht tr hcb hs,
         insertNonFull_occupancy t x ht tr true hcb hocc hnf,
         insertNonFull_sameDepth t x ht hcb hsd⟩

Top-level CLRS insertion adds exactly one occurrence of the requested key, including when the old root must first be split.


theorem insertRoot_keys_perm
    (t x : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hwf : WellFormed t tr) :
    (keysOf (insertRoot t x tr)).Perm (keysOf tr ++ [x]) := by
  by_cases hfull : rootKeyCount tr = 2 * t - 1
  · rw [insertRoot, if_pos hfull]
    have hsplitWf := splitRoot_wellFormed t ht hwf hfull
    exact
      (insertNonFull_keys_perm t x ht (splitRoot t tr) hsplitWf.2.1).trans
        ((splitRoot_keys_perm t ht hfull).append_right [x])
  · rw [insertRoot, if_neg hfull]
    exact insertNonFull_keys_perm t x ht tr hwf.2.1

Top-level CLRS insertion preserves every structural B-tree invariant.


theorem insertRoot_wellFormed
    (t x : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hwf : WellFormed t tr) :
    WellFormed t (insertRoot t x tr) := by
  by_cases hfull : rootKeyCount tr = 2 * t - 1
  · rw [insertRoot, if_pos hfull]
    exact
      insertNonFull_wellFormed t x ht
        (splitRoot_wellFormed t ht hwf hfull)
        (splitRoot_nonFull t ht hfull)
  · have hle : rootKeyCount tr ≤ 2 * t - 1 := by
      cases tr with
      | node ks cs =>
          have hocc := hwf.2.2.1
          unfold Occupancy at hocc
          exact hocc.2.1
    have hnf : rootKeyCount tr < 2 * t - 1 := by
      omega
    rw [insertRoot, if_neg hfull]
    exact insertNonFull_wellFormed t x ht hwf hnf

Top-level CLRS insertion preserves height unless it splits a full root, in which case it adds exactly one level.


theorem insertRoot_height
    (t x : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hwf : WellFormed t tr) :
    heightOf (insertRoot t x tr) =
      if rootKeyCount tr = 2 * t - 1 then heightOf tr + 1
      else heightOf tr := by
  by_cases hfull : rootKeyCount tr = 2 * t - 1
  · rw [insertRoot, if_pos hfull, if_pos hfull]
    have hsplitWf := splitRoot_wellFormed t ht hwf hfull
    exact
      (insertNonFull_height t x ht hsplitWf.2.1 hsplitWf.2.2.2).trans
        (splitRoot_height t ht hwf hfull)
  · rw [insertRoot, if_neg hfull, if_neg hfull]
    exact insertNonFull_height t x ht hwf.2.1 hwf.2.2.2

Membership after top-level CLRS insertion is old membership or equality with the inserted key.


theorem insertRoot_mem_iff
    (t x y : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hwf : WellFormed t tr) :
    mem y (insertRoot t x tr) ↔ y = x ∨ mem y tr := by
  unfold mem
  rw [(insertRoot_keys_perm t x ht hwf).mem_iff, List.mem_append,
    List.mem_singleton]
  exact or_comm

Top-level CLRS insertion preserves global key uniqueness when the inserted key was absent from the input tree.


theorem insertRoot_wellFormedUnique
    (t x : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hwf : WellFormedUnique t tr)
    (hnot : ¬ mem x tr) :
    WellFormedUnique t (insertRoot t x tr) := by
  refine ⟨insertRoot_wellFormed t x ht hwf.1, ?_⟩
  have hkeys : (keysOf tr ++ [x]).Nodup := by
    rw [List.nodup_append]
    refine ⟨hwf.2, by simp, ?_⟩
    intro a ha b hb
    simp only [List.mem_singleton] at hb
    subst b
    intro hax
    subst a
    exact hnot ha
  exact (insertRoot_keys_perm t x ht hwf.1).nodup_iff.mpr hkeys

Executable top-level insertion and specification insertion have identical membership semantics.

theorem insertRoot_mem_iff_insert
    (t x y : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hwf : WellFormed t tr) :
    mem y (insertRoot t x tr) ↔ mem y (insert x tr) :=
  (insertRoot_mem_iff t x y ht hwf).trans (insert_mem_iff x y tr).symm

Membership-oracle search agrees after executable and specification insertion.

theorem insertRoot_search_eq_insert
    (t x y : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hwf : WellFormed t tr) :
    search y (insertRoot t x tr) = search y (insert x tr) := by
  apply Bool.eq_iff_iff.mpr
  simpa only [search_true_iff] using
    insertRoot_mem_iff_insert t x y ht hwf

Executable search after top-level insertion succeeds exactly for the inserted key or an old member.

theorem insertRoot_searchExec_true_iff
    (t x y : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hwf : WellFormed t tr) :
    searchExec y (insertRoot t x tr) = true ↔ y = x ∨ mem y tr := by
  have hout := insertRoot_wellFormed t x ht hwf
  exact
    (searchExec_true_iff hout.1 hout.2.1).trans
      (insertRoot_mem_iff t x y ht hwf)

Top-level CLRS insertion simultaneously has exact add-one semantics, preserves well-formedness, and preserves or increases height by one level.

theorem insertRoot_correct
    (t x : Nat) (ht : 2 ≤ t) {tr : BTree}
    (hwf : WellFormed t tr) :
    (keysOf (insertRoot t x tr)).Perm (keysOf tr ++ [x]) ∧
    WellFormed t (insertRoot t x tr) ∧
    (heightOf (insertRoot t x tr) = heightOf tr ∨
      heightOf (insertRoot t x tr) = heightOf tr + 1) := by
  refine
    ⟨insertRoot_keys_perm t x ht hwf,
      insertRoot_wellFormed t x ht hwf, ?_⟩
  have hheight := insertRoot_height t x ht hwf
  by_cases hfull : rootKeyCount tr = 2 * t - 1
  · right
    simpa [hfull] using hheight
  · left
    simpa [hfull] using hheight

              end BTreeend Chapter18end CLRS

Imports

import CLRSLean.FourthEdition.Chapter_18.Section_18_1_B_Tree_Model
import CLRSLean.FourthEdition.Chapter_18.Section_18_2_B_Tree_Insertion

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_old and BTree.delete_not_mem_of_eq: old absent keys and keys equal to the deleted key remain absent after deletion.
Theorems BTree.delete_not_mem and BTree.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, and BTree.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, and BTree.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 BTree

Specification-level B-tree deletion: remove all occurrences of a key.

def delete (x : Nat) (t : BTree) : BTree :=
  node ((keysOf t).filter (fun y => y != x)) []

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 hvalid

Specification 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) hvalid

Specification 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]
  simp

Old 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.2

Old 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 hy

Any 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 hyx

Searching 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) hvalid

Old 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 hcases

Old 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 hy

Old 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 hc

Structural 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 heq

Occupancy (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 [This simp argument is unused:
  List.nil_append

Hint: Omit it from the simp argument list.
  simp only [̵L̵i̵s̵t̵.̵n̵i̵l̵_̵a̵p̵p̵e̵n̵d̵,̵ ̵L̵i̵s̵t̵.̵t̵a̵k̵e̵_̵n̵i̵l̵,̵[̲L̲i̲s̲t̲.̲t̲a̲k̲e̲_̲n̲i̲l̲,̲ List.append_nil]

Note: This linter can be disabled with `set_option linter.unusedSimpArgs false`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, This simp argument is unused:
  List.not_mem_nil

Hint: Omit it from the simp argument list.
  simp only [keysOf, List.mem_append, List.mem_cons, L̵i̵s̵t̵.̵n̵o̵t̵_̵m̵e̵m̵_̵n̵i̵l̵,̵ ̵or_false, List.flatMap_append]

Note: This linter can be disabled with `set_option linter.unusedSimpArgs false`List.not_mem_nil, This simp argument is unused:
  or_false

Hint: Omit it from the simp argument list.
  simp only [keysOf, List.mem_append, List.mem_cons, List.not_mem_nil, o̵r̵_̵f̵a̵l̵s̵e̵,̵
  ̵ ̵ ̵ ̵ ̵ ̵ ̵ ̵ ̵ ̵ ̵List.flatMap_append]

Note: This linter can be disabled with `set_option linter.unusedSimpArgs false`or_false,
          List.flatMap_append]
        rw [hb1, hb2]
        tauto

Helper functions for the composed delete

Number of keys in a B-tree node.

def numKeys : BTree → Nat
  | node ks _ => ks.length

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 [] = [] := rfl

lemma 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, This simp argument is unused:
  hr

Hint: Omit it from the simp argument list.
  simp [heightOf,̵ ̵h̵r̵]

Note: This linter can be disabled with `set_option linter.unusedSimpArgs false`hr]
      · by_cases hr : rCh = []
        · subst hr; simp [heightOf, This simp argument is unused:
  hl

Hint: Omit it from the simp argument list.
  simp [heightOf,̵ ̵h̵l̵]

Note: This linter can be disabled with `set_option linter.unusedSimpArgs false`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, This simp argument is unused:
  hl

Hint: Omit it from the simp argument list.
  simp [heightOf, hl̵,̵ ̵h̵A]

Note: This linter can be disabled with `set_option linter.unusedSimpArgs false`hl, hA]
          have hrCh_ht : heightOf (node rKeys rCh) = 1 + B := by
            simp [heightOf, This simp argument is unused:
  hr

Hint: Omit it from the simp argument list.
  simp [heightOf, hr̵,̵ ̵h̵B]

Note: This linter can be disabled with `set_option linter.unusedSimpArgs false`hr, hB]
          have hmerged_ht : heightOf (node (lKeys ++ sep :: rKeys) (lCh ++ rCh)) = 1 + (((lCh ++ rCh).map heightOf).foldl max 0) := by
            simp [heightOf, This simp argument is unused:
  hne

Hint: Omit it from the simp argument list.
  simp [heightOf,̵ ̵h̵n̵e̵]

Note: This linter can be disabled with `set_option linter.unusedSimpArgs false`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.

instance : Inhabited BTree := ⟨node [] []⟩

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 hj

Hereditary 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 c

Rightmost 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 hne

The 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 hne

Every 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 hne

Every 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) (Variable name `ht` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`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) (Variable name `ht` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`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) [] — remove x from the key list.
Case 1 (x = ks[ki] hits a separator, ki = findChild ks x - 1):
- 1a left child has ≥ t keys: replace the separator by m := maxKey leftChild and recursively delete m from the left child.
- 1b else the right child has ≥ t keys: symmetric, with m := minKey rightChild deleted from the right child.
- 1c else both children are minimal: merge them around x and recurse into the merged node (as before).
Case 2 (descend into child j, three descent sites: k ≠ x, ks[ki]? = none, and findChild ks x = 0): guarded descent —
- child has ≥ t keys: descend directly (as before);
- else the left sibling cs[j-1] exists (j > 0) and has ≥ t keys: rotateLeft borrows across separator ks[j-1], descend into the repaired child;
- else the right sibling cs[j+1] exists and has ≥ t keys: rotateRight borrows across separator ks[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 = 0 descent 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 Variable name `hiPos` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hiPos : 0 < i then
        let ki := i - 1
        match Variable name `hk` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hk : ks[ki]? with
        | some k =>
          if Variable name `hkeq` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hkeq : k = x then
            match Variable name `hcl` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hcl : cs[ki]? with
            | some leftChild =>
              match Variable name `hcr` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hcr : cs[ki + 1]? with
              | some rightChild =>
                if Variable name `hla` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`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 Variable name `hc` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hc : cs[i]? with
            | some child =>
              if Variable name `hcg` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hcg : t ≤ numKeys child then
                node ks (cs.set i (composedDelete t x child))
              else
                match Variable name `hls` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hls : cs[i - 1]? with
                | some leftSib =>
                  if Variable name `hlg` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`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 Variable name `hrs` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hrs : cs[i + 1]? with
                    | some rightSib =>
                      if Variable name `hrg` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`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 Variable name `hsep` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`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 Variable name `hsep` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`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 Variable name `hc` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hc : cs[i]? with
          | some child =>
            if Variable name `hcg` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hcg : t ≤ numKeys child then
              node ks (cs.set i (composedDelete t x child))
            else
              match Variable name `hls` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hls : cs[i - 1]? with
              | some leftSib =>
                if Variable name `hlg` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`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 Variable name `hrs` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hrs : cs[i + 1]? with
                  | some rightSib =>
                    if Variable name `hrg` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`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 Variable name `hsep` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`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 Variable name `hsep` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`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 Variable name `hc` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hc : cs[0]? with
        | some child =>
          if Variable name `hcg` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hcg : t ≤ numKeys child then
            node ks (cs.set 0 (composedDelete t x child))
          else
            match Variable name `hrs` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hrs : cs[1]? with
            | some rightSib =>
              if Variable name `hrg` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`hrg : t ≤ numKeys rightSib then
                match Variable name `hsep` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`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 Variable name `hsep` is not explicitly referenced.

The binding can be removed (if unused) or named `_` (if used implicitly).

Note: This linter can be disabled with `set_option linter.unusedVariables false`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 CLRS

Definitions 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 BTree

Raw 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.1

              end BTreeend Chapter18end CLRS

CLRSLean.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 : _ < _, _›
          omega

Raw 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 hpacket

Raw 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 hpacket

end CLRS.Chapter18.BTree

CLRSLean.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 : _ < _, _›
          omega

Executable 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 hinv

Deletion 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 hmem

Exact 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.BTree

CLRSLean.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 BTree

Replacing 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) hchildren

Replacing 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 hroute

Changing 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_rfl

Replacing 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
  · simp

Splicing 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_rfl

After 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 hroute

Replacing 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
  · simp

Every 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 ⊢ <;>
    aesop

Every 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_rfl

A 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 hfinal

After 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 hfinal

              end BTreeend Chapter18end CLRS

CLRSLean.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 BTree

Bundled 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.

def DeleteReady (t : Nat) (isRoot : Bool) (tr : BTree) : Prop :=
  isRoot = true ∨ t ≤ numKeys tr

Every key represented after an operation was represented before it.

def KeysSubset (after before : BTree) : Prop :=
  ∀ k, k ∈ keysOf after → k ∈ keysOf before

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 NodeWF

Project sortedness from the deletion invariant packet.

theorem sorted {t : Nat} {isRoot : Bool} {tr : BTree}
    (h : NodeWF t isRoot tr) : Sorted tr :=
  h.1

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.1

Project 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.1

Project 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.2

end NodeWFnamespace WellFormed

A well-formed tree is the root-specialized deletion invariant packet.

theorem nodeWF {t : Nat} {tr : BTree}
    (h : WellFormed t tr) : NodeWF t true tr :=
  h

end WellFormed

Root 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 hkeys

Every 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 h

Root normalization

Contract an empty root with exactly one child; leave every other tree unchanged.

def normalizeRoot : BTree → BTree
  | node [] [child] => child
  | tr => tr

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 => rfl

Root 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 rfl

private 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 => rfl

Normalizing 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 hi

A 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 hsep

namespace NodeWF

Every 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 hchild

An 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 hne

A 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
  omega

The 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 hchild

At 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 hleft

Every 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.1

The 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 hright

Project 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
  omega

namespace KeysSubset

Every tree's represented keys are a subset of themselves.

theorem refl (tr : BTree) : KeysSubset tr tr := by
  intro k hk
  exact hk

Key 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 CLRS

CLRSLean.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 BTree

The represented keys of a B-tree, retaining multiplicity and ignoring order.

def keyBag (tr : BTree) : Multiset Nat :=
  ↑(keysOf tr)

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]
  abel

Removing 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]
  abel

A 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]
          abel

Borrowing 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]
                  abel

Borrowing 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]
              abel

              end BTreeend Chapter18end CLRS

CLRSLean.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 CLRS

CLRSLean.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.occupancy

end CLRS.Chapter18.BTree

CLRSLean.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 tr

An 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 CLRS

CLRSLean.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 ReassemblyInternal

Every 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 hj

Every 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 hidx

Replacing 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 ReassemblyInternal

Replacing 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 hchild

Predecessor/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 CLRS

CLRSLean.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
  omega

Two 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]
  omega

              end BTreeend Chapter18end CLRS

CLRSLean.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 hc

              end BTreeend Chapter18end CLRS

CLRSLean.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 BTree

After 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 hrightLower

After 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 CLRS

CLRSLean.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 CLRS

CLRSLean.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) hbounded

Replacing 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 hrightPacket

Replacing 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 houtChildrenHeight

A 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 hsep

A 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 hnone

The 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
        · assumption

Raw 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.BTree

CLRSLean.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 BTree

Raw 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.1

              end BTreeend Chapter18end CLRS

CLRSLean.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 BTree

Result 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 hk

Key-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 CLRS

CLRSLean.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 BTree

Root-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 hk

Root 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 hraw

Root-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 hraw

When 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 hxBag

Under 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 hmem

Root-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).symm

On 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 hwf

Root-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

Scope and implementation notes

Imports

import CLRSLean.FourthEdition.Chapter_18.Section_18_1_B_Tree_Model
import CLRSLean.FourthEdition.Chapter_18.Section_18_1_B_Tree_Model.Search
import CLRSLean.FourthEdition.Chapter_18.Section_18_1_B_Tree_Model.HeightBound
import CLRSLean.FourthEdition.Chapter_18.Section_18_1_B_Tree_Model.RunningTime
import CLRSLean.FourthEdition.Chapter_18.Section_18_2_B_Tree_Insertion
import CLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion
import CLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.Invariant
import CLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.Rotation
import CLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.Repair
import CLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.Preservation
import CLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.Reassembly
import CLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.MergeReassembly
import CLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.RotationBounds
import CLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.RotationReassembly
import CLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.ComposedPreservation
import CLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.KeyMultiset
import CLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.ExactReassembly
import CLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.Exact
import CLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.Subset
import CLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.SameDepthHeight
import CLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.Sorted
import CLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.ChildBounded
import CLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.Occupancy
import CLRSLean.FourthEdition.Chapter_18.Section_18_3_B_Tree_Deletion.WellFormed

Current source

Sections 18.1--18.3 are native fourth-edition sections (definition of B-trees, basic operations on B-trees, and deleting a key from a B-tree), imported directly from Section 18.1, Section 18.2, and Section 18.3. Section 18.1 includes the nested search, height-bound, and running-time developments; section 18.3 includes the nested deletion-invariant and reassembly developments. Declarations retain the CLRS.Chapter18 namespace during the compatibility period; the third-edition-numbered imports CLRSLean.Chapter_18 and CLRSLean.Chapter_18.Section_18_* forward to these sources.

Coverage boundary

The existing B-tree search, insertion/deletion structure, and exact key-bag semantics are preserved. The running-time companion bounds recursive-descent charges by height and a logarithmic key-count envelope. Its historical diskAccessBound name does not mean a complete page-I/O count: split, borrow, merge, predecessor/successor helper traversals, and storage internals are not individually counted or connected by a constant-factor theorem.

See docs/clrs-fourth-edition-map.csv for the section-level mapping and docs/migrations/clrs4.md for compatibility and deprecation policy.

CLRS, fourth edition · Chapter 18 of 35

18.1. B-Tree Model

Implementation details

Keys and membership

Minimum-key lower bound expression

Structural invariants

B-TREE-SPLIT-CHILD operation

Occupancy preservation under splitChild

List utility: foldl max over uniform values

SameDepth infrastructure and preservation

Height of a SameDepth internal node

splitChild occupancy preservation (stub)

ChildBounded preservation infrastructure

Definitions and proofs

CLRS Section 18.1 - B-tree key count and height bound

Exact key accounting

Internal-child projections

Non-root minimum-key bound

Root minimum-key and logarithmic-height bounds

CLRS Chapter 18 - B-tree running time

Recursive-descent charges

Height bounds

Deletion height bound

Top-level insertion cost

Logarithmic descent-budget bounds

CLRS Section 18.1 - Separator-guided B-tree search

Child selection

Height lemmas

Child-index bounds and range correctness

Executable search

18.2. B-Tree Insertion

Compatibility wrappers for B-TREE-SPLIT-CHILD

Real recursive insertion (CLRS B-TREE-INSERT-NONFULL)

insertNonFull

sortedInsert correctness

insertNonFull key multiset

SameDepth and height preservation

Bridge to splitChild for the Sorted / ChildBounded proofs

ChildBounded preservation

Occupancy preservation

Top-level B-TREE-INSERT operations

18.3. B-Tree Deletion

Implementation details

Node-level deletion repair: SameDepth / heightOf infrastructure

mergeNodes: combine two sibling subtrees around a separator key

mergeNodes: occupancy preservation

mergeNodes preserves ChildBounded

mergeNodes preserves Sorted

Structural preservation architecture

Occupancy (de)constructors and shared repair infrastructure

rotateRight: borrow a key from the right sibling (CLRS case 3a)

rotateLeft: borrow a key from the left sibling (CLRS case 3a, symmetric)

keysOf membership across rotations

Helper functions for the composed delete

sortedRemove length bounds

sortedRemove preserves leaf invariants

Composed delete (CLRS B-TREE-DELETE)

Height of mergeNodes (for termination of composedDelete)

Unconditional height bounds for rotations (termination of composedDelete)

maxKey / minKey: rightmost / leftmost key read

AllKeysPos from Occupancy, and preservation across merge/rotations

Definitions and proofs

B-tree deletion: child-bound projection

Complete structural preservation for composed B-tree deletion

Exact semantics for raw B-tree deletion

Exact parent reassembly for B-tree deletion

Invariant contracts for composed B-tree deletion

Bundled deletion contracts

Root normalization

Recursive-descent lookup and guard helpers

Exact key multisets for B-tree deletion

Parent reassembly after merging adjacent B-tree children

Non-root occupancy preservation for composed B-tree deletion

Bundled preservation for B-tree deletion

Parent reassembly packets for B-tree deletion

Predecessor/successor parent packets

Bundled local repair invariants for B-tree deletion

Readiness of repaired recursive targets

B-tree deletion: rotations preserve Sorted and ChildBounded

rotateRight: the new left node preserves Sorted

rotateRight: the new nodes preserve ChildBounded

Compatibility wrappers for `B-TREE-SPLIT-CHILD`

Real recursive insertion (CLRS `B-TREE-INSERT-NONFULL`)

`insertNonFull`

`sortedInsert` correctness

`insertNonFull` key multiset

`SameDepth` and height preservation

Bridge to `splitChild` for the Sorted / ChildBounded proofs

Top-level `B-TREE-INSERT` operations

Node-level deletion repair: `SameDepth` / `heightOf` infrastructure

`mergeNodes`: combine two sibling subtrees around a separator key

`mergeNodes`: occupancy preservation

`mergeNodes` preserves `ChildBounded`

`mergeNodes` preserves `Sorted`

`rotateRight`: borrow a key from the right sibling (CLRS case 3a)

`rotateLeft`: borrow a key from the left sibling (CLRS case 3a, symmetric)

`keysOf` membership across rotations

`sortedRemove` length bounds

`sortedRemove` preserves leaf invariants

Unconditional height bounds for rotations (termination of `composedDelete`)

`maxKey` / `minKey`: rightmost / leftmost key read

`AllKeysPos` from `Occupancy`, and preservation across merge/rotations

B-tree deletion: rotations preserve `Sorted` and `ChildBounded`

`rotateRight`: the new left node preserves `Sorted`

`rotateRight`: the new nodes preserve `ChildBounded`

`rotateLeft`: the new nodes preserve `Sorted`

`rotateLeft`: the new nodes preserve `ChildBounded`