(* Title: RBT.thy ID: $Id: RBT.thy,v 1.1 2008/03/03 13:03:20 krauss Exp $ Author: Markus Reiter, TU Muenchen Author: Alexander Krauss, TU Muenchen *) header {* Red-Black Trees *} (*<*) theory RBT imports Main AssocList begin datatype color = R | B datatype ('a,'b)"rbt" = Empty | Tr color "('a,'b)rbt" 'a 'b "('a,'b)rbt" (* Suchbaum-Eigenschaften *) primrec pin_tree :: "'a => 'b => ('a,'b) rbt => bool" where "pin_tree k v Empty = False" | "pin_tree k v (Tr c l x y r) = (k = x ∧ v = y ∨ pin_tree k v l ∨ pin_tree k v r)" primrec keys :: "('k,'v) rbt => 'k set" where "keys Empty = {}" | "keys (Tr _ l k _ r) = { k } ∪ keys l ∪ keys r" lemma pint_keys: "pin_tree k v t ==> k ∈ keys t" by (induct t) auto primrec tlt :: "'a::order => ('a,'b) rbt => bool" where "tlt k Empty = True" | "tlt k (Tr c lt kt v rt) = (kt < k ∧ tlt k lt ∧ tlt k rt)" abbreviation tllt (infix "|«" 50) where "t |« x == tlt x t" primrec tgt :: "'a::order => ('a,'b) rbt => bool" (infix "«|" 50) where "tgt k Empty = True" | "tgt k (Tr c lt kt v rt) = (k < kt ∧ tgt k lt ∧ tgt k rt)" lemma tlt_prop: "(t |« k) = (∀x∈keys t. x < k)" by (induct t) auto lemma tgt_prop: "(k «| t) = (∀x∈keys t. k < x)" by (induct t) auto lemmas tlgt_props = tlt_prop tgt_prop lemmas tgt_nit = tgt_prop pint_keys lemmas tlt_nit = tlt_prop pint_keys lemma tlt_trans: "[| t |« x; x < y |] ==> t |« y" and tgt_trans: "[| x < y; y «| t|] ==> x «| t" by (auto simp: tlgt_props) primrec st :: "('a::linorder, 'b) rbt => bool" where "st Empty = True" | "st (Tr c l k v r) = (l |« k ∧ k «| r ∧ st l ∧ st r)" primrec map_of :: "('a::linorder, 'b) rbt => 'a \<rightharpoonup> 'b" where "map_of Empty k = None" | "map_of (Tr _ l x y r) k = (if k < x then map_of l k else if x < k then map_of r k else Some y)" lemma map_of_tlt[simp]: "t |« k ==> map_of t k = None" by (induct t) auto lemma map_of_tgt[simp]: "k «| t ==> map_of t k = None" by (induct t) auto lemma mapof_keys: "st t ==> dom (map_of t) = keys t" by (induct t) (auto simp: dom_def tgt_prop tlt_prop) lemma mapof_pit: "st t ==> (map_of t k = Some v) = pin_tree k v t" by (induct t) (auto simp: tlt_prop tgt_prop pint_keys) lemma map_of_Empty: "map_of Empty = empty" by (rule ext) simp (* a kind of extensionality *) lemma mapof_from_pit: assumes st: "st t1" "st t2" and eq: "!!v. pin_tree (k::'a::linorder) v t1 = pin_tree k v t2" shows "map_of t1 k = map_of t2 k" proof (cases "map_of t1 k") case None then have "!!v. ¬ pin_tree k v t1" by (simp add: mapof_pit[symmetric] st) with None show ?thesis by (cases "map_of t2 k") (auto simp: mapof_pit st eq) next case (Some a) then show ?thesis apply (cases "map_of t2 k") apply (auto simp: mapof_pit st eq) by (auto simp add: mapof_pit[symmetric] st Some) qed subsection {* Red-black properties *} primrec treec :: "('a,'b) rbt => color" where "treec Empty = B" | "treec (Tr c _ _ _ _) = c" primrec inv1 :: "('a,'b) rbt => bool" where "inv1 Empty = True" | "inv1 (Tr c lt k v rt) = (inv1 lt ∧ inv1 rt ∧ (c = B ∨ treec lt = B ∧ treec rt = B))" (* Weaker version *) primrec inv1l :: "('a,'b) rbt => bool" where "inv1l Empty = True" | "inv1l (Tr c l k v r) = (inv1 l ∧ inv1 r)" lemma [simp]: "inv1 t ==> inv1l t" by (cases t) simp+ primrec bh :: "('a,'b) rbt => nat" where "bh Empty = 0" | "bh (Tr c lt k v rt) = (if c = B then Suc (bh lt) else bh lt)" primrec inv2 :: "('a,'b) rbt => bool" where "inv2 Empty = True" | "inv2 (Tr c lt k v rt) = (inv2 lt ∧ inv2 rt ∧ bh lt = bh rt)" definition "isrbt t = (inv1 t ∧ inv2 t ∧ treec t = B ∧ st t)" lemma isrbt_st[simp]: "isrbt t ==> st t" by (simp add: isrbt_def) lemma rbt_cases: obtains (Empty) "t = Empty" | (Red) l k v r where "t = Tr R l k v r" | (Black) l k v r where "t = Tr B l k v r" by (cases t, simp) (case_tac "color", auto) theorem Empty_isrbt[simp]: "isrbt Empty" unfolding isrbt_def by simp subsection {* Insertion *} fun (* slow, due to massive case splitting *) balance :: "('a,'b) rbt => 'a => 'b => ('a,'b) rbt => ('a,'b) rbt" where "balance (Tr R a w x b) s t (Tr R c y z d) = Tr R (Tr B a w x b) s t (Tr B c y z d)" | "balance (Tr R (Tr R a w x b) s t c) y z d = Tr R (Tr B a w x b) s t (Tr B c y z d)" | "balance (Tr R a w x (Tr R b s t c)) y z d = Tr R (Tr B a w x b) s t (Tr B c y z d)" | "balance a w x (Tr R b s t (Tr R c y z d)) = Tr R (Tr B a w x b) s t (Tr B c y z d)" | "balance a w x (Tr R (Tr R b s t c) y z d) = Tr R (Tr B a w x b) s t (Tr B c y z d)" | "balance a s t b = Tr B a s t b" lemma balance_inv1: "[|inv1l l; inv1l r|] ==> inv1 (balance l k v r)" by (induct l k v r rule: balance.induct) auto lemma balance_bh: "bh l = bh r ==> bh (balance l k v r) = Suc (bh l)" by (induct l k v r rule: balance.induct) auto lemma balance_inv2: assumes "inv2 l" "inv2 r" "bh l = bh r" shows "inv2 (balance l k v r)" using assms by (induct l k v r rule: balance.induct) auto lemma balance_tgt[simp]: "(v «| balance a k x b) = (v «| a ∧ v «| b ∧ v < k)" by (induct a k x b rule: balance.induct) auto lemma balance_tlt[simp]: "(balance a k x b |« v) = (a |« v ∧ b |« v ∧ k < v)" by (induct a k x b rule: balance.induct) auto lemma balance_st: fixes k :: "'a::linorder" assumes "st l" "st r" "l |« k" "k «| r" shows "st (balance l k v r)" using assms proof (induct l k v r rule: balance.induct) case ("2_2" a x w b y t c z s va vb vd vc) hence "y < z ∧ z «| Tr B va vb vd vc" by (auto simp add: tlgt_props) hence "tgt y (Tr B va vb vd vc)" by (blast dest: tgt_trans) with "2_2" show ?case by simp next case ("3_2" va vb vd vc x w b y s c z) from "3_2" have "x < y ∧ tlt x (Tr B va vb vd vc)" by (simp add: tlt.simps tgt.simps) hence "tlt y (Tr B va vb vd vc)" by (blast dest: tlt_trans) with "3_2" show ?case by simp next case ("3_3" x w b y s c z t va vb vd vc) from "3_3" have "y < z ∧ tgt z (Tr B va vb vd vc)" by simp hence "tgt y (Tr B va vb vd vc)" by (blast dest: tgt_trans) with "3_3" show ?case by simp next case ("3_4" vd ve vg vf x w b y s c z t va vb vii vc) hence "x < y ∧ tlt x (Tr B vd ve vg vf)" by simp hence 1: "tlt y (Tr B vd ve vg vf)" by (blast dest: tlt_trans) from "3_4" have "y < z ∧ tgt z (Tr B va vb vii vc)" by simp hence "tgt y (Tr B va vb vii vc)" by (blast dest: tgt_trans) with 1 "3_4" show ?case by simp next case ("4_2" va vb vd vc x w b y s c z t dd) hence "x < y ∧ tlt x (Tr B va vb vd vc)" by simp hence "tlt y (Tr B va vb vd vc)" by (blast dest: tlt_trans) with "4_2" show ?case by simp next case ("5_2" x w b y s c z t va vb vd vc) hence "y < z ∧ tgt z (Tr B va vb vd vc)" by simp hence "tgt y (Tr B va vb vd vc)" by (blast dest: tgt_trans) with "5_2" show ?case by simp next case ("5_3" va vb vd vc x w b y s c z t) hence "x < y ∧ tlt x (Tr B va vb vd vc)" by simp hence "tlt y (Tr B va vb vd vc)" by (blast dest: tlt_trans) with "5_3" show ?case by simp next case ("5_4" va vb vg vc x w b y s c z t vd ve vii vf) hence "x < y ∧ tlt x (Tr B va vb vg vc)" by simp hence 1: "tlt y (Tr B va vb vg vc)" by (blast dest: tlt_trans) from "5_4" have "y < z ∧ tgt z (Tr B vd ve vii vf)" by simp hence "tgt y (Tr B vd ve vii vf)" by (blast dest: tgt_trans) with 1 "5_4" show ?case by simp qed simp+ lemma keys_balance[simp]: "keys (balance l k v r) = { k } ∪ keys l ∪ keys r" by (induct l k v r rule: balance.induct) auto lemma balance_pit: "pin_tree k x (balance l v y r) = (pin_tree k x l ∨ k = v ∧ x = y ∨ pin_tree k x r)" by (induct l v y r rule: balance.induct) auto lemma map_of_balance[simp]: fixes k :: "'a::linorder" assumes "st l" "st r" "l |« k" "k «| r" shows "map_of (balance l k v r) x = map_of (Tr B l k v r) x" by (rule mapof_from_pit) (auto simp:assms balance_pit balance_st) primrec paint :: "color => ('a,'b) rbt => ('a,'b) rbt" where "paint c Empty = Empty" | "paint c (Tr _ l k v r) = Tr c l k v r" lemma paint_inv1l[simp]: "inv1l t ==> inv1l (paint c t)" by (cases t) auto lemma paint_inv1[simp]: "inv1l t ==> inv1 (paint B t)" by (cases t) auto lemma paint_inv2[simp]: "inv2 t ==> inv2 (paint c t)" by (cases t) auto lemma paint_treec[simp]: "treec (paint B t) = B" by (cases t) auto lemma paint_st[simp]: "st t ==> st (paint c t)" by (cases t) auto lemma paint_pit[simp]: "pin_tree k x (paint c t) = pin_tree k x t" by (cases t) auto lemma paint_mapof[simp]: "map_of (paint c t) = map_of t" by (rule ext) (cases t, auto) lemma paint_tgt[simp]: "(v «| paint c t) = (v «| t)" by (cases t) auto lemma paint_tlt[simp]: "(paint c t |« v) = (t |« v)" by (cases t) auto fun ins :: "('a::linorder => 'b => 'b => 'b) => 'a => 'b => ('a,'b) rbt => ('a,'b) rbt" where "ins f k v Empty = Tr R Empty k v Empty" | "ins f k v (Tr B l x y r) = (if k < x then balance (ins f k v l) x y r else if k > x then balance l x y (ins f k v r) else Tr B l x (f k y v) r)" | "ins f k v (Tr R l x y r) = (if k < x then Tr R (ins f k v l) x y r else if k > x then Tr R l x y (ins f k v r) else Tr R l x (f k y v) r)" lemma ins_inv1_inv2: assumes "inv1 t" "inv2 t" shows "inv2 (ins f k x t)" "bh (ins f k x t) = bh t" "treec t = B ==> inv1 (ins f k x t)" "inv1l (ins f k x t)" using assms by (induct f k x t rule: ins.induct) (auto simp: balance_inv1 balance_inv2 balance_bh) lemma ins_tgt[simp]: "(v «| ins f k x t) = (v «| t ∧ k > v)" by (induct f k x t rule: ins.induct) auto lemma ins_tlt[simp]: "(ins f k x t |« v) = (t |« v ∧ k < v)" by (induct f k x t rule: ins.induct) auto lemma ins_st[simp]: "st t ==> st (ins f k x t)" by (induct f k x t rule: ins.induct) (auto simp: balance_st) lemma keys_ins: "keys (ins f k v t) = { k } ∪ keys t" by (induct f k v t rule: ins.induct) auto lemma map_of_ins: fixes k :: "'a::linorder" assumes "st t" shows "map_of (ins f k v t) x = ((map_of t)(k |-> case map_of t k of None => v | Some w => f k w v)) x" using assms by (induct f k v t rule: ins.induct) auto definition insertwithkey :: "('a::linorder => 'b => 'b => 'b) => 'a => 'b => ('a,'b) rbt => ('a,'b) rbt" where "insertwithkey f k v t = paint B (ins f k v t)" lemma insertwk_st: "st t ==> st (insertwithkey f k x t)" by (auto simp: insertwithkey_def) theorem insertwk_isrbt: assumes inv: "isrbt t" shows "isrbt (insertwithkey f k x t)" using assms unfolding insertwithkey_def isrbt_def by (auto simp: ins_inv1_inv2) lemma map_of_insertwk: assumes "st t" shows "map_of (insertwithkey f k v t) x = ((map_of t)(k |-> case map_of t k of None => v | Some w => f k w v)) x" unfolding insertwithkey_def using assms by (simp add:map_of_ins) definition insertw_def: "insertwith f = insertwithkey (λ_. f)" lemma insertw_st: "st t ==> st (insertwith f k v t)" by (simp add: insertwk_st insertw_def) theorem insertw_isrbt: "isrbt t ==> isrbt (insertwith f k v t)" by (simp add: insertwk_isrbt insertw_def) lemma map_of_insertw: assumes "isrbt t" shows "map_of (insertwith f k v t) = (map_of t)(k \<mapsto> (if k:dom (map_of t) then f (the (map_of t k)) v else v))" using assms unfolding insertw_def by (rule_tac ext) (cases "map_of t k", auto simp:map_of_insertwk dom_def) definition "insrt k v t = insertwithkey (λ_ _ nv. nv) k v t" lemma insrt_st: "st t ==> st (insrt k v t)" by (simp add: insertwk_st insrt_def) theorem insrt_isrbt: "isrbt t ==> isrbt (insrt k v t)" by (simp add: insertwk_isrbt insrt_def) lemma map_of_insert: assumes "isrbt t" shows "map_of (insrt k v t) = (map_of t)(k\<mapsto>v)" unfolding insrt_def using assms by (rule_tac ext) (simp add: map_of_insertwk split:option.split) subsection {* Deletion *} (*definition [simp]: "ibn t = (bh t > 0 ∧ treec t = B)" *) lemma bh_paintR'[simp]: "treec t = B ==> bh (paint R t) = bh t - 1" by (cases t rule: rbt_cases) auto fun balleft :: "('a,'b) rbt => 'a => 'b => ('a,'b) rbt => ('a,'b) rbt" where "balleft (Tr R a k x b) s y c = Tr R (Tr B a k x b) s y c" | "balleft bl k x (Tr B a s y b) = balance bl k x (Tr R a s y b)" | "balleft bl k x (Tr R (Tr B a s y b) t z c) = Tr R (Tr B bl k x a) s y (balance b t z (paint R c))" | "balleft t k x s = Empty" lemma balleft_inv2_with_inv1: assumes "inv2 lt" "inv2 rt" "bh lt + 1 = bh rt" "inv1 rt" shows "bh (balleft lt k v rt) = bh lt + 1" and "inv2 (balleft lt k v rt)" using assms by (induct lt k v rt rule: balleft.induct) (auto simp: balance_inv2 balance_bh) lemma balleft_inv2_app: assumes "inv2 lt" "inv2 rt" "bh lt + 1 = bh rt" "treec rt = B" shows "inv2 (balleft lt k v rt)" "bh (balleft lt k v rt) = bh rt" using assms by (induct lt k v rt rule: balleft.induct) (auto simp add: balance_inv2 balance_bh)+ lemma balleft_inv1: "[|inv1l a; inv1 b; treec b = B|] ==> inv1 (balleft a k x b)" by (induct a k x b rule: balleft.induct) (simp add: balance_inv1)+ lemma balleft_inv1l: "[| inv1l lt; inv1 rt |] ==> inv1l (balleft lt k x rt)" by (induct lt k x rt rule: balleft.induct) (auto simp: balance_inv1) lemma balleft_st: "[| st l; st r; tlt k l; tgt k r |] ==> st (balleft l k v r)" apply (induct l k v r rule: balleft.induct) apply (auto simp: balance_st) apply (unfold tgt_prop tlt_prop) by force+ lemma balleft_tgt: fixes k :: "'a::order" assumes "k «| a" "k «| b" "k < x" shows "k «| balleft a x t b" using assms by (induct a x t b rule: balleft.induct) auto lemma balleft_tlt: fixes k :: "'a::order" assumes "a |« k" "b |« k" "x < k" shows "balleft a x t b |« k" using assms by (induct a x t b rule: balleft.induct) auto lemma balleft_pit: assumes "inv1l l" "inv1 r" "bh l + 1 = bh r" shows "pin_tree k v (balleft l a b r) = (pin_tree k v l ∨ k = a ∧ v = b ∨ pin_tree k v r)" using assms by (induct l k v r rule: balleft.induct) (auto simp: balance_pit) fun balright :: "('a,'b) rbt => 'a => 'b => ('a,'b) rbt => ('a,'b) rbt" where "balright a k x (Tr R b s y c) = Tr R a k x (Tr B b s y c)" | "balright (Tr B a k x b) s y bl = balance (Tr R a k x b) s y bl" | "balright (Tr R a k x (Tr B b s y c)) t z bl = Tr R (balance (paint R a) k x b) s y (Tr B c t z bl)" | "balright t k x s = Empty" lemma balright_inv2_with_inv1: assumes "inv2 lt" "inv2 rt" "bh lt = bh rt + 1" "inv1 lt" shows "inv2 (balright lt k v rt) ∧ bh (balright lt k v rt) = bh lt" using assms by (induct lt k v rt rule: balright.induct) (auto simp: balance_inv2 balance_bh) lemma balright_inv1: "[|inv1 a; inv1l b; treec a = B|] ==> inv1 (balright a k x b)" by (induct a k x b rule: balright.induct) (simp add: balance_inv1)+ lemma balright_inv1l: "[| inv1 lt; inv1l rt |] ==>inv1l (balright lt k x rt)" by (induct lt k x rt rule: balright.induct) (auto simp: balance_inv1) lemma balright_st: "[| st l; st r; tlt k l; tgt k r |] ==> st (balright l k v r)" apply (induct l k v r rule: balright.induct) apply (auto simp:balance_st) apply (unfold tlt_prop tgt_prop) by force+ lemma balright_tgt: fixes k :: "'a::order" assumes "k «| a" "k «| b" "k < x" shows "k «| balright a x t b" using assms by (induct a x t b rule: balright.induct) auto lemma balright_tlt: fixes k :: "'a::order" assumes "a |« k" "b |« k" "x < k" shows "balright a x t b |« k" using assms by (induct a x t b rule: balright.induct) auto lemma balright_pit: assumes "inv1 l" "inv1l r" "bh l = bh r + 1" "inv2 l" "inv2 r" shows "pin_tree x y (balright l k v r) = (pin_tree x y l ∨ x = k ∧ y = v ∨ pin_tree x y r)" using assms by (induct l k v r rule: balright.induct) (auto simp: balance_pit) text {* app *} fun app :: "('a,'b) rbt => ('a,'b) rbt => ('a,'b) rbt" where "app Empty x = x" | "app x Empty = x" | "app (Tr R a k x b) (Tr R c s y d) = (case (app b c) of Tr R b2 t z c2 => (Tr R (Tr R a k x b2) t z (Tr R c2 s y d)) | bc => Tr R a k x (Tr R bc s y d))" | "app (Tr B a k x b) (Tr B c s y d) = (case (app b c) of Tr R b2 t z c2 => Tr R (Tr B a k x b2) t z (Tr B c2 s y d) | bc => balleft a k x (Tr B bc s y d))" | "app a (Tr R b k x c) = Tr R (app a b) k x c" | "app (Tr R a k x b) c = Tr R a k x (app b c)" lemma app_inv2: assumes "inv2 lt" "inv2 rt" "bh lt = bh rt" shows "bh (app lt rt) = bh lt" "inv2 (app lt rt)" using assms by (induct lt rt rule: app.induct) (auto simp: balleft_inv2_app split: rbt.splits color.splits) lemma app_inv1: assumes "inv1 lt" "inv1 rt" shows "treec lt = B ==> treec rt = B ==> inv1 (app lt rt)" "inv1l (app lt rt)" using assms by (induct lt rt rule: app.induct) (auto simp: balleft_inv1 split: rbt.splits color.splits) lemma app_tgt[simp]: fixes k :: "'a::linorder" assumes "k «| l" "k «| r" shows "k «| app l r" using assms by (induct l r rule: app.induct) (auto simp: balleft_tgt split:rbt.splits color.splits) lemma app_tlt[simp]: fixes k :: "'a::linorder" assumes "l |« k" "r |« k" shows "app l r |« k" using assms by (induct l r rule: app.induct) (auto simp: balleft_tlt split:rbt.splits color.splits) lemma app_st: fixes k :: "'a::linorder" assumes "st l" "st r" "l |« k" "k «| r" shows "st (app l r)" using assms proof (induct l r rule: app.induct) case (3 a x v b c y w d) hence ineqs: "a |« x" "x «| b" "b |« k" "k «| c" "c |« y" "y «| d" by auto with 3 show ?case apply (cases "app b c" rule: rbt_cases) apply auto by (metis app_tgt app_tlt ineqs ineqs tlt.simps(2) tgt.simps(2) tgt_trans tlt_trans)+ next case (4 a x v b c y w d) hence "x < k ∧ tgt k c" by simp hence "tgt x c" by (blast dest: tgt_trans) with 4 have 2: "tgt x (app b c)" by (simp add: app_tgt) from 4 have "k < y ∧ tlt k b" by simp hence "tlt y b" by (blast dest: tlt_trans) with 4 have 3: "tlt y (app b c)" by (simp add: app_tlt) show ?case proof (cases "app b c" rule: rbt_cases) case Empty from 4 have "x < y ∧ tgt y d" by auto hence "tgt x d" by (blast dest: tgt_trans) with 4 Empty have "st a" and "st (Tr B Empty y w d)" and "tlt x a" and "tgt x (Tr B Empty y w d)" by auto with Empty show ?thesis by (simp add: balleft_st) next case (Red lta va ka rta) with 2 4 have "x < va ∧ tlt x a" by simp hence 5: "tlt va a" by (blast dest: tlt_trans) from Red 3 4 have "va < y ∧ tgt y d" by simp hence "tgt va d" by (blast dest: tgt_trans) with Red 2 3 4 5 show ?thesis by simp next case (Black lta va ka rta) from 4 have "x < y ∧ tgt y d" by auto hence "tgt x d" by (blast dest: tgt_trans) with Black 2 3 4 have "st a" and "st (Tr B (app b c) y w d)" and "tlt x a" and "tgt x (Tr B (app b c) y w d)" by auto with Black show ?thesis by (simp add: balleft_st) qed next case (5 va vb vd vc b x w c) hence "k < x ∧ tlt k (Tr B va vb vd vc)" by simp hence "tlt x (Tr B va vb vd vc)" by (blast dest: tlt_trans) with 5 show ?case by (simp add: app_tlt) next case (6 a x v b va vb vd vc) hence "x < k ∧ tgt k (Tr B va vb vd vc)" by simp hence "tgt x (Tr B va vb vd vc)" by (blast dest: tgt_trans) with 6 show ?case by (simp add: app_tgt) qed simp+ lemma app_pit: assumes "inv2 l" "inv2 r" "bh l = bh r" "inv1 l" "inv1 r" shows "pin_tree k v (app l r) = (pin_tree k v l ∨ pin_tree k v r)" using assms proof (induct l r rule: app.induct) case (4 _ _ _ b c) hence a: "bh (app b c) = bh b" by (simp add: app_inv2) from 4 have b: "inv1l (app b c)" by (simp add: app_inv1) show ?case proof (cases "app b c" rule: rbt_cases) case Empty with 4 a show ?thesis by (auto simp: balleft_pit) next case (Red lta ka va rta) with 4 show ?thesis by auto next case (Black lta ka va rta) with a b 4 show ?thesis by (auto simp: balleft_pit) qed qed (auto split: rbt.splits color.splits) fun delformLeft :: "('a::linorder) => ('a,'b) rbt => 'a => 'b => ('a,'b) rbt => ('a,'b) rbt" and delformRight :: "('a::linorder) => ('a,'b) rbt => 'a => 'b => ('a,'b) rbt => ('a,'b) rbt" and del :: "('a::linorder) => ('a,'b) rbt => ('a,'b) rbt" where "del x Empty = Empty" | "del x (Tr c a y s b) = (if x < y then delformLeft x a y s b else (if x > y then delformRight x a y s b else app a b))" | "delformLeft x (Tr B lt z v rt) y s b = balleft (del x (Tr B lt z v rt)) y s b" | "delformLeft x a y s b = Tr R (del x a) y s b" | "delformRight x a y s (Tr B lt z v rt) = balright a y s (del x (Tr B lt z v rt))" | "delformRight x a y s b = Tr R a y s (del x b)" lemma assumes "inv2 lt" "inv1 lt" shows "[|inv2 rt; bh lt = bh rt; inv1 rt|] ==> inv2 (delformLeft x lt k v rt) ∧ bh (delformLeft x lt k v rt) = bh lt ∧ (treec lt = B ∧ treec rt = B ∧ inv1 (delformLeft x lt k v rt) ∨ (treec lt ≠ B ∨ treec rt ≠ B) ∧ inv1l (delformLeft x lt k v rt))" and "[|inv2 rt; bh lt = bh rt; inv1 rt|] ==> inv2 (delformRight x lt k v rt) ∧ bh (delformRight x lt k v rt) = bh lt ∧ (treec lt = B ∧ treec rt = B ∧ inv1 (delformRight x lt k v rt) ∨ (treec lt ≠ B ∨ treec rt ≠ B) ∧ inv1l (delformRight x lt k v rt))" and del_inv1_inv2: "inv2 (del x lt) ∧ (treec lt = R ∧ bh (del x lt) = bh lt ∧ inv1 (del x lt) ∨ treec lt = B ∧ bh (del x lt) = bh lt - 1 ∧ inv1l (del x lt))" using assms proof (induct x lt k v rt and x lt k v rt and x lt rule: delformLeft_delformRight_del.induct) case (2 y c _ y') have "y = y' ∨ y < y' ∨ y > y'" by auto thus ?case proof (elim disjE) assume "y = y'" with 2 show ?thesis by (cases c) (simp add: app_inv2 app_inv1)+ next assume "y < y'" with 2 show ?thesis by (cases c) auto next assume "y' < y" with 2 show ?thesis by (cases c) auto qed next case (3 y lt z v rta y' ss bb) thus ?case by (cases "treec (Tr B lt z v rta) = B ∧ treec bb = B") (simp add: balleft_inv2_with_inv1 balleft_inv1 balleft_inv1l)+ next case (5 y a y' ss lt z v rta) thus ?case by (cases "treec a = B ∧ treec (Tr B lt z v rta) = B") (simp add: balright_inv2_with_inv1 balright_inv1 balright_inv1l)+ next case ("6_1" y a y' ss) thus ?case by (cases "treec a = B ∧ treec Empty = B") simp+ qed auto lemma delformLeft_tlt: "[|tlt v lt; tlt v rt; k < v|] ==> tlt v (delformLeft x lt k y rt)" and delformRight_tlt: "[|tlt v lt; tlt v rt; k < v|] ==> tlt v (delformRight x lt k y rt)" and del_tlt: "tlt v lt ==> tlt v (del x lt)" by (induct x lt k y rt and x lt k y rt and x lt rule: delformLeft_delformRight_del.induct) (auto simp: balleft_tlt balright_tlt) lemma delformLeft_tgt: "[|tgt v lt; tgt v rt; k > v|] ==> tgt v (delformLeft x lt k y rt)" and delformRight_tgt: "[|tgt v lt; tgt v rt; k > v|] ==> tgt v (delformRight x lt k y rt)" and del_tgt: "tgt v lt ==> tgt v (del x lt)" by (induct x lt k y rt and x lt k y rt and x lt rule: delformLeft_delformRight_del.induct) (auto simp: balleft_tgt balright_tgt) lemma "[|st lt; st rt; tlt k lt; tgt k rt|] ==> st (delformLeft x lt k y rt)" and "[|st lt; st rt; tlt k lt; tgt k rt|] ==> st (delformRight x lt k y rt)" and del_st: "st lt ==> st (del x lt)" proof (induct x lt k y rt and x lt k y rt and x lt rule: delformLeft_delformRight_del.induct) case (3 x lta zz v rta yy ss bb) from 3 have "tlt yy (Tr B lta zz v rta)" by simp hence "tlt yy (del x (Tr B lta zz v rta))" by (rule del_tlt) with 3 show ?case by (simp add: balleft_st) next case ("4_2" x vaa vbb vdd vc yy ss bb) hence "tlt yy (Tr R vaa vbb vdd vc)" by simp hence "tlt yy (del x (Tr R vaa vbb vdd vc))" by (rule del_tlt) with "4_2" show ?case by simp next case (5 x aa yy ss lta zz v rta) hence "tgt yy (Tr B lta zz v rta)" by simp hence "tgt yy (del x (Tr B lta zz v rta))" by (rule del_tgt) with 5 show ?case by (simp add: balright_st) next case ("6_2" x aa yy ss vaa vbb vdd vc) hence "tgt yy (Tr R vaa vbb vdd vc)" by simp hence "tgt yy (del x (Tr R vaa vbb vdd vc))" by (rule del_tgt) with "6_2" show ?case by simp qed (auto simp: app_st) lemma "[|st lt; st rt; tlt kt lt; tgt kt rt; inv1 lt; inv1 rt; inv2 lt; inv2 rt; bh lt = bh rt; x < kt|] ==> pin_tree k v (delformLeft x lt kt y rt) = (False ∨ (x ≠ k ∧ pin_tree k v (Tr c lt kt y rt)))" and "[|st lt; st rt; tlt kt lt; tgt kt rt; inv1 lt; inv1 rt; inv2 lt; inv2 rt; bh lt = bh rt; x > kt|] ==> pin_tree k v (delformRight x lt kt y rt) = (False ∨ (x ≠ k ∧ pin_tree k v (Tr c lt kt y rt)))" and del_pit: "[|st t; inv1 t; inv2 t|] ==> pin_tree k v (del x t) = (False ∨ (x ≠ k ∧ pin_tree k v t))" proof (induct x lt kt y rt and x lt kt y rt and x t rule: delformLeft_delformRight_del.induct) case (2 xx c aa yy ss bb) have "xx = yy ∨ xx < yy ∨ xx > yy" by auto from this 2 show ?case proof (elim disjE) assume "xx = yy" with 2 show ?thesis proof (cases "xx = k") case True from 2 `xx = yy` `xx = k` have "st (Tr c aa yy ss bb) ∧ k = yy" by simp hence "¬ pin_tree k v aa" "¬ pin_tree k v bb" by (auto simp: tlt_nit tgt_prop) with `xx = yy` 2 `xx = k` show ?thesis by (simp add: app_pit) qed (simp add: app_pit) qed simp+ next case (3 xx lta zz vv rta yy ss bb) def mt[simp]: mt == "Tr B lta zz vv rta" from 3 have "inv2 mt ∧ inv1 mt" by simp hence "inv2 (del xx mt) ∧ (treec mt = R ∧ bh (del xx mt) = bh mt ∧ inv1 (del xx mt) ∨ treec mt = B ∧ bh (del xx mt) = bh mt - 1 ∧ inv1l (del xx mt))" by (blast dest: del_inv1_inv2) with 3 have 4: "pin_tree k v (delformLeft xx mt yy ss bb) = (False ∨ xx ≠ k ∧ pin_tree k v mt ∨ (k = yy ∧ v = ss) ∨ pin_tree k v bb)" by (simp add: balleft_pit) thus ?case proof (cases "xx = k") case True from 3 True have "tgt yy bb ∧ yy > k" by simp hence "tgt k bb" by (blast dest: tgt_trans) with 3 4 True show ?thesis by (auto simp: tgt_nit) qed auto next case ("4_1" xx yy ss bb) show ?case proof (cases "xx = k") case True with "4_1" have "tgt yy bb ∧ k < yy" by simp hence "tgt k bb" by (blast dest: tgt_trans) with "4_1" `xx = k` have "pin_tree k v (Tr R Empty yy ss bb) = pin_tree k v Empty" by (auto simp: tgt_nit) thus ?thesis by auto qed simp+ next case ("4_2" xx vaa vbb vdd vc yy ss bb) thus ?case proof (cases "xx = k") case True with "4_2" have "k < yy ∧ tgt yy bb" by simp hence "tgt k bb" by (blast dest: tgt_trans) with True "4_2" show ?thesis by (auto simp: tgt_nit) qed simp next case (5 xx aa yy ss lta zz vv rta) def mt[simp]: mt == "Tr B lta zz vv rta" from 5 have "inv2 mt ∧ inv1 mt" by simp hence "inv2 (del xx mt) ∧ (treec mt = R ∧ bh (del xx mt) = bh mt ∧ inv1 (del xx mt) ∨ treec mt = B ∧ bh (del xx mt) = bh mt - 1 ∧ inv1l (del xx mt))" by (blast dest: del_inv1_inv2) with 5 have 3: "pin_tree k v (delformRight xx aa yy ss mt) = (pin_tree k v aa ∨ (k = yy ∧ v = ss) ∨ False ∨ xx ≠ k ∧ pin_tree k v mt)" by (simp add: balright_pit) thus ?case proof (cases "xx = k") case True from 5 True have "tlt yy aa ∧ yy < k" by simp hence "tlt k aa" by (blast dest: tlt_trans) with 3 5 True show ?thesis by (auto simp: tlt_nit) qed auto next case ("6_1" xx aa yy ss) show ?case proof (cases "xx = k") case True with "6_1" have "tlt yy aa ∧ k > yy" by simp hence "tlt k aa" by (blast dest: tlt_trans) with "6_1" `xx = k` show ?thesis by (auto simp: tlt_nit) qed simp next case ("6_2" xx aa yy ss vaa vbb vdd vc) thus ?case proof (cases "xx = k") case True with "6_2" have "k > yy ∧ tlt yy aa" by simp hence "tlt k aa" by (blast dest: tlt_trans) with True "6_2" show ?thesis by (auto simp: tlt_nit) qed simp qed simp definition delete where delete_def: "delete k t = paint B (del k t)" theorem delete_isrbt[simp]: assumes "isrbt t" shows "isrbt (delete k t)" proof - from assms have "inv2 t" and "inv1 t" unfolding isrbt_def by auto hence "inv2 (del k t) ∧ (treec t = R ∧ bh (del k t) = bh t ∧ inv1 (del k t) ∨ treec t = B ∧ bh (del k t) = bh t - 1 ∧ inv1l (del k t))" by (rule del_inv1_inv2) hence "inv2 (del k t) ∧ inv1l (del k t)" by (cases "treec t") auto with assms show ?thesis unfolding isrbt_def delete_def by (auto intro: paint_st del_st) qed lemma delete_pit: assumes "isrbt t" shows "pin_tree k v (delete x t) = (x ≠ k ∧ pin_tree k v t)" using assms unfolding isrbt_def delete_def by (auto simp: del_pit) lemma map_of_delete: assumes isrbt: "isrbt t" shows "map_of (delete k t) = (map_of t)|`(-{k})" proof fix x show "map_of (delete k t) x = (map_of t |` (-{k})) x" proof (cases "x = k") assume "x = k" with isrbt show ?thesis by (cases "map_of (delete k t) k") (auto simp: mapof_pit delete_pit) next assume "x ≠ k" thus ?thesis by auto (metis isrbt delete_isrbt delete_pit isrbt_st mapof_from_pit) qed qed subsection {* Union *} primrec unionwithkey :: "('a::linorder => 'b => 'b => 'b) => ('a,'b) rbt => ('a,'b) rbt => ('a,'b) rbt" where "unionwithkey f t Empty = t" | "unionwithkey f t (Tr c lt k v rt) = unionwithkey f (unionwithkey f (insertwithkey f k v t) lt) rt" lemma unionwk_st: "st lt ==> st (unionwithkey f lt rt)" by (induct rt arbitrary: lt) (auto simp: insertwk_st) theorem unionwk_isrbt[simp]: "isrbt lt ==> isrbt (unionwithkey f lt rt)" by (induct rt arbitrary: lt) (simp add: insertwk_isrbt)+ definition unionwith where "unionwith f = unionwithkey (λ_. f)" theorem unionw_isrbt: "isrbt lt ==> isrbt (unionwith f lt rt)" unfolding unionwith_def by simp definition union where "union = unionwithkey (%_ _ rv. rv)" theorem union_isrbt: "isrbt lt ==> isrbt (union lt rt)" unfolding union_def by simp lemma union_Tr[simp]: "union t (Tr c lt k v rt) = union (union (insrt k v t) lt) rt" unfolding union_def insrt_def by simp lemma map_of_union: assumes "isrbt s" "st t" shows "map_of (union s t) = map_of s ++ map_of t" using assms proof (induct t arbitrary: s) case Empty thus ?case by (auto simp: union_def) next case (Tr c l k v r s) hence strl: "st r" "st l" "l |« k" "k «| r" by auto have meq: "map_of s(k \<mapsto> v) ++ map_of l ++ map_of r = map_of s ++ (λa. if a < k then map_of l a else if k < a then map_of r a else Some v)" (is "?m1 = ?m2") proof (rule ext) fix a have "k < a ∨ k = a ∨ k > a" by auto thus "?m1 a = ?m2 a" proof (elim disjE) assume "k < a" with `l |« k` have "l |« a" by (rule tlt_trans) with `k < a` show ?thesis by (auto simp: map_add_def split: option.splits) next assume "k = a" with `l |« k` `k «| r` show ?thesis by (auto simp: map_add_def) next assume "a < k" from this `k «| r` have "a «| r" by (rule tgt_trans) with `a < k` show ?thesis by (auto simp: map_add_def split: option.splits) qed qed from Tr have IHs: "map_of (union (union (insrt k v s) l) r) = map_of (union (insrt k v s) l) ++ map_of r" "map_of (union (insrt k v s) l) = map_of (insrt k v s) ++ map_of l" by (auto intro: union_isrbt insrt_isrbt) with meq show ?case by (auto simp: map_of_insert[OF Tr(3)]) qed subsection {* Adjust *} primrec adjustwithkey :: "('a => 'b => 'b) => ('a::linorder) => ('a,'b) rbt => ('a,'b) rbt" where "adjustwithkey f k Empty = Empty" | "adjustwithkey f k (Tr c lt x v rt) = (if k < x then (Tr c (adjustwithkey f k lt) x v rt) else if k > x then (Tr c lt x v (adjustwithkey f k rt)) else (Tr c lt x (f x v) rt))" lemma adjustwk_treec: "treec (adjustwithkey f k t) = treec t" by (induct t) simp+ lemma adjustwk_inv1: "inv1 (adjustwithkey f k t) = inv1 t" by (induct t) (simp add: adjustwk_treec)+ lemma adjustwk_inv2: "inv2 (adjustwithkey f k t) = inv2 t" "bh (adjustwithkey f k t) = bh t" by (induct t) simp+ lemma adjustwk_tgt: "tgt k (adjustwithkey f kk t) = tgt k t" by (induct t) simp+ lemma adjustwk_tlt: "tlt k (adjustwithkey f kk t) = tlt k t" by (induct t) simp+ lemma adjustwk_st: "st (adjustwithkey f k t) = st t" by (induct t) (simp add: adjustwk_tlt adjustwk_tgt)+ theorem adjustwk_isrbt[simp]: "isrbt (adjustwithkey f k t) = isrbt t" unfolding isrbt_def by (simp add: adjustwk_inv2 adjustwk_treec adjustwk_st adjustwk_inv1 ) theorem adjustwithkey_map[simp]: "map_of (adjustwithkey f k t) x = (if x = k then case map_of t x of None => None | Some y => Some (f k y) else map_of t x)" by (induct t arbitrary: x) (auto split:option.splits) definition adjust where "adjust f = adjustwithkey (λ_. f)" theorem adjust_isrbt[simp]: "isrbt (adjust f k t) = isrbt t" unfolding adjust_def by simp theorem adjust_map[simp]: "map_of (adjust f k t) x = (if x = k then case map_of t x of None => None | Some y => Some (f y) else map_of t x)" unfolding adjust_def by simp subsection {* Map *} primrec mapwithkey :: "('a::linorder => 'b => 'c) => ('a,'b) rbt => ('a,'c) rbt" where "mapwithkey f Empty = Empty" | "mapwithkey f (Tr c lt k v rt) = Tr c (mapwithkey f lt) k (f k v) (mapwithkey f rt)" theorem mapwk_keys[simp]: "keys (mapwithkey f t) = keys t" by (induct t) auto lemma mapwk_tgt: "tgt k (mapwithkey f t) = tgt k t" by (induct t) simp+ lemma mapwk_tlt: "tlt k (mapwithkey f t) = tlt k t" by (induct t) simp+ lemma mapwk_st: "st (mapwithkey f t) = st t" by (induct t) (simp add: mapwk_tlt mapwk_tgt)+ lemma mapwk_treec: "treec (mapwithkey f t) = treec t" by (induct t) simp+ lemma mapwk_inv1: "inv1 (mapwithkey f t) = inv1 t" by (induct t) (simp add: mapwk_treec)+ lemma mapwk_inv2: "inv2 (mapwithkey f t) = inv2 t" "bh (mapwithkey f t) = bh t" by (induct t) simp+ theorem mapwk_isrbt[simp]: "isrbt (mapwithkey f t) = isrbt t" unfolding isrbt_def by (simp add: mapwk_inv1 mapwk_inv2 mapwk_st mapwk_treec) theorem map_of_mapwk[simp]: "map_of (mapwithkey f t) x = option_map (f x) (map_of t x)" by (induct t) auto definition map where map_def: "map f == mapwithkey (λ_. f)" theorem map_keys[simp]: "keys (map f t) = keys t" unfolding map_def by simp theorem map_isrbt[simp]: "isrbt (map f t) = isrbt t" unfolding map_def by simp theorem map_of_map[simp]: "map_of (map f t) = option_map f o map_of t" by (rule ext) (simp add:map_def) subsection {* Fold *} text {* The following is still incomplete... *} primrec foldwithkey :: "('a::linorder => 'b => 'c => 'c) => ('a,'b) rbt => 'c => 'c" where "foldwithkey f Empty v = v" | "foldwithkey f (Tr c lt k x rt) v = foldwithkey f rt (f k x (foldwithkey f lt v))" primrec alist_of where "alist_of Empty = []" | "alist_of (Tr _ l k v r) = alist_of l @ (k,v) # alist_of r" lemma map_of_alist_of: shows "st t ==> Map.map_of (alist_of t) = map_of t" oops lemma fold_alist_fold: "foldwithkey f t x = foldl (λx (k,v). f k v x) x (alist_of t)" by (induct t arbitrary: x) auto lemma alist_pit[simp]: "(k, v) ∈ set (alist_of t) = pin_tree k v t" by (induct t) auto lemma sorted_alist: "st t ==> sorted (List.map fst (alist_of t))" by (induct t) (force simp: sorted_append sorted_Cons tlgt_props dest!:pint_keys)+ lemma distinct_alist: "st t ==> distinct (List.map fst (alist_of t))" by (induct t) (force simp: sorted_append sorted_Cons tlgt_props dest!:pint_keys)+ (*>*) text {* This theory defines purely functional red-black trees which can be used as an efficient representation of finite maps. *} subsection {* Data type and invariant *} text {* The type @{typ "('k, 'v) rbt"} denotes red-black trees with keys of type @{typ "'k"} and values of type @{typ "'v"}. To function properly, the key type must belong to the @{text "linorder"} class. A value @{term t} of this type is a valid red-black tree if it satisfies the invariant @{text "isrbt t"}. This theory provides lemmas to prove that the invariant is satisfied throughout the computation. The interpretation function @{const "map_of"} returns the partial map represented by a red-black tree: @{term_type[display] "map_of"} This function should be used for reasoning about the semantics of the RBT operations. Furthermore, it implements the lookup functionality for the data structure: It is executable and the lookup is performed in $O(\log n)$. *} subsection {* Operations *} text {* Currently, the following operations are supported: @{term_type[display] "Empty"} Returns the empty tree. $O(1)$ @{term_type[display] "insrt"} Updates the map at a given position. $O(\log n)$ @{term_type[display] "delete"} Deletes a map entry at a given position. $O(\log n)$ @{term_type[display] "union"} Forms the union of two trees, preferring entries from the first one. @{term_type[display] "map"} Maps a function over the values of a map. $O(n)$ *} subsection {* Invariant preservation *} text {* \noindent @{thm Empty_isrbt}\hfill(@{text "Empty_isrbt"}) \noindent @{thm insrt_isrbt}\hfill(@{text "insrt_isrbt"}) \noindent @{thm delete_isrbt}\hfill(@{text "delete_isrbt"}) \noindent @{thm union_isrbt}\hfill(@{text "union_isrbt"}) \noindent @{thm map_isrbt}\hfill(@{text "map_isrbt"}) *} subsection {* Map Semantics *} text {* \noindent \underline{@{text "map_of_Empty"}} @{thm[display] map_of_Empty} \vspace{1ex} \noindent \underline{@{text "map_of_insert"}} @{thm[display] map_of_insert} \vspace{1ex} \noindent \underline{@{text "map_of_delete"}} @{thm[display] map_of_delete} \vspace{1ex} \noindent \underline{@{text "map_of_union"}} @{thm[display] map_of_union} \vspace{1ex} \noindent \underline{@{text "map_of_map"}} @{thm[display] map_of_map} \vspace{1ex} *} end
lemma pint_keys:
pin_tree k v t ==> k ∈ keys t
lemma tlt_prop:
(t |« k) = (∀x∈keys t. x < k)
lemma tgt_prop:
(k «| t) = (∀x∈keys t. k < x)
lemma tlgt_props:
(t |« k) = (∀x∈keys t. x < k)
(k «| t) = (∀x∈keys t. k < x)
lemma tgt_nit:
(k «| t) = (∀x∈keys t. k < x)
pin_tree k v t ==> k ∈ keys t
lemma tlt_nit:
(t |« k) = (∀x∈keys t. x < k)
pin_tree k v t ==> k ∈ keys t
lemma tlt_trans:
[| t |« x; x < y |] ==> t |« y
and tgt_trans:
[| x < y; y «| t |] ==> x «| t
lemma map_of_tlt:
t |« k ==> RBT.map_of t k = None
lemma map_of_tgt:
k «| t ==> RBT.map_of t k = None
lemma mapof_keys:
st t ==> dom (RBT.map_of t) = keys t
lemma mapof_pit:
st t ==> (RBT.map_of t k = Some v) = pin_tree k v t
lemma map_of_Empty:
RBT.map_of Empty = empty
lemma mapof_from_pit:
[| st t1.0; st t2.0; !!v. pin_tree k v t1.0 = pin_tree k v t2.0 |]
==> RBT.map_of t1.0 k = RBT.map_of t2.0 k
lemma
inv1 t ==> inv1l t
lemma isrbt_st:
isrbt t ==> st t
lemma rbt_cases:
[| t = Empty ==> thesis; !!l k v r. t = Tr R l k v r ==> thesis;
!!l k v r. t = Tr B l k v r ==> thesis |]
==> thesis
theorem Empty_isrbt:
isrbt Empty
lemma balance_inv1:
[| inv1l l; inv1l r |] ==> inv1 (balance l k v r)
lemma balance_bh:
bh l = bh r ==> bh (balance l k v r) = Suc (bh l)
lemma balance_inv2:
[| inv2 l; inv2 r; bh l = bh r |] ==> inv2 (balance l k v r)
lemma balance_tgt:
(v «| balance a k x b) = (v «| a ∧ v «| b ∧ v < k)
lemma balance_tlt:
(balance a k x b |« v) = (a |« v ∧ b |« v ∧ k < v)
lemma balance_st:
[| st l; st r; l |« k; k «| r |] ==> st (balance l k v r)
lemma keys_balance:
keys (balance l k v r) = {k} ∪ keys l ∪ keys r
lemma balance_pit:
pin_tree k x (balance l v y r) =
(pin_tree k x l ∨ k = v ∧ x = y ∨ pin_tree k x r)
lemma map_of_balance:
[| st l; st r; l |« k; k «| r |]
==> RBT.map_of (balance l k v r) x = RBT.map_of (Tr B l k v r) x
lemma paint_inv1l:
inv1l t ==> inv1l (paint c t)
lemma paint_inv1:
inv1l t ==> inv1 (paint B t)
lemma paint_inv2:
inv2 t ==> inv2 (paint c t)
lemma paint_treec:
treec (paint B t) = B
lemma paint_st:
st t ==> st (paint c t)
lemma paint_pit:
pin_tree k x (paint c t) = pin_tree k x t
lemma paint_mapof:
RBT.map_of (paint c t) = RBT.map_of t
lemma paint_tgt:
(v «| paint c t) = (v «| t)
lemma paint_tlt:
(paint c t |« v) = (t |« v)
lemma ins_inv1_inv2:
[| inv1 t; inv2 t |] ==> inv2 (ins f k x t)
[| inv1 t; inv2 t |] ==> bh (ins f k x t) = bh t
[| inv1 t; inv2 t; treec t = B |] ==> inv1 (ins f k x t)
[| inv1 t; inv2 t |] ==> inv1l (ins f k x t)
lemma ins_tgt:
(v «| ins f k x t) = (v «| t ∧ v < k)
lemma ins_tlt:
(ins f k x t |« v) = (t |« v ∧ k < v)
lemma ins_st:
st t ==> st (ins f k x t)
lemma keys_ins:
keys (ins f k v t) = {k} ∪ keys t
lemma map_of_ins:
st t
==> RBT.map_of (ins f k v t) x =
(RBT.map_of t(k |-> case RBT.map_of t k of None => v | Some w => f k w v)) x
lemma insertwk_st:
st t ==> st (insertwithkey f k x t)
theorem insertwk_isrbt:
isrbt t ==> isrbt (insertwithkey f k x t)
lemma map_of_insertwk:
st t
==> RBT.map_of (insertwithkey f k v t) x =
(RBT.map_of t(k |-> case RBT.map_of t k of None => v | Some w => f k w v)) x
lemma insertw_st:
st t ==> st (insertwith f k v t)
theorem insertw_isrbt:
isrbt t ==> isrbt (insertwith f k v t)
lemma map_of_insertw:
isrbt t
==> RBT.map_of (insertwith f k v t) = RBT.map_of t(k |->
if k ∈ dom (RBT.map_of t) then f (the (RBT.map_of t k)) v else v)
lemma insrt_st:
st t ==> st (insrt k v t)
theorem insrt_isrbt:
isrbt t ==> isrbt (insrt k v t)
lemma map_of_insert:
isrbt t ==> RBT.map_of (insrt k v t) = RBT.map_of t(k |-> v)
lemma bh_paintR':
treec t = B ==> bh (paint R t) = bh t - 1
lemma balleft_inv2_with_inv1(1):
[| inv2 lt; inv2 rt; bh lt + 1 = bh rt; inv1 rt |]
==> bh (balleft lt k v rt) = bh lt + 1
and balleft_inv2_with_inv1(2):
[| inv2 lt; inv2 rt; bh lt + 1 = bh rt; inv1 rt |] ==> inv2 (balleft lt k v rt)
lemma balleft_inv2_app:
[| inv2 lt; inv2 rt; bh lt + 1 = bh rt; treec rt = B |]
==> inv2 (balleft lt k v rt)
[| inv2 lt; inv2 rt; bh lt + 1 = bh rt; treec rt = B |]
==> bh (balleft lt k v rt) = bh rt
lemma balleft_inv1:
[| inv1l a; inv1 b; treec b = B |] ==> inv1 (balleft a k x b)
lemma balleft_inv1l:
[| inv1l lt; inv1 rt |] ==> inv1l (balleft lt k x rt)
lemma balleft_st:
[| st l; st r; l |« k; k «| r |] ==> st (balleft l k v r)
lemma balleft_tgt:
[| k «| a; k «| b; k < x |] ==> k «| balleft a x t b
lemma balleft_tlt:
[| a |« k; b |« k; x < k |] ==> balleft a x t b |« k
lemma balleft_pit:
[| inv1l l; inv1 r; bh l + 1 = bh r |]
==> pin_tree k v (balleft l a b r) =
(pin_tree k v l ∨ k = a ∧ v = b ∨ pin_tree k v r)
lemma balright_inv2_with_inv1:
[| inv2 lt; inv2 rt; bh lt = bh rt + 1; inv1 lt |]
==> inv2 (balright lt k v rt) ∧ bh (balright lt k v rt) = bh lt
lemma balright_inv1:
[| inv1 a; inv1l b; treec a = B |] ==> inv1 (balright a k x b)
lemma balright_inv1l:
[| inv1 lt; inv1l rt |] ==> inv1l (balright lt k x rt)
lemma balright_st:
[| st l; st r; l |« k; k «| r |] ==> st (balright l k v r)
lemma balright_tgt:
[| k «| a; k «| b; k < x |] ==> k «| balright a x t b
lemma balright_tlt:
[| a |« k; b |« k; x < k |] ==> balright a x t b |« k
lemma balright_pit:
[| inv1 l; inv1l r; bh l = bh r + 1; inv2 l; inv2 r |]
==> pin_tree x y (balright l k v r) =
(pin_tree x y l ∨ x = k ∧ y = v ∨ pin_tree x y r)
lemma app_inv2:
[| inv2 lt; inv2 rt; bh lt = bh rt |] ==> bh (app lt rt) = bh lt
[| inv2 lt; inv2 rt; bh lt = bh rt |] ==> inv2 (app lt rt)
lemma app_inv1:
[| inv1 lt; inv1 rt; treec lt = B; treec rt = B |] ==> inv1 (app lt rt)
[| inv1 lt; inv1 rt |] ==> inv1l (app lt rt)
lemma app_tgt:
[| k «| l; k «| r |] ==> k «| app l r
lemma app_tlt:
[| l |« k; r |« k |] ==> app l r |« k
lemma app_st:
[| st l; st r; l |« k; k «| r |] ==> st (app l r)
lemma app_pit:
[| inv2 l; inv2 r; bh l = bh r; inv1 l; inv1 r |]
==> pin_tree k v (app l r) = (pin_tree k v l ∨ pin_tree k v r)
lemma
[| inv2 lt; inv1 lt; inv2 rt; bh lt = bh rt; inv1 rt |]
==> inv2 (delformLeft x lt k v rt) ∧
bh (delformLeft x lt k v rt) = bh lt ∧
(treec lt = B ∧ treec rt = B ∧ inv1 (delformLeft x lt k v rt) ∨
(treec lt ≠ B ∨ treec rt ≠ B) ∧ inv1l (delformLeft x lt k v rt))
and
[| inv2 lt; inv1 lt; inv2 rt; bh lt = bh rt; inv1 rt |]
==> inv2 (delformRight x lt k v rt) ∧
bh (delformRight x lt k v rt) = bh lt ∧
(treec lt = B ∧ treec rt = B ∧ inv1 (delformRight x lt k v rt) ∨
(treec lt ≠ B ∨ treec rt ≠ B) ∧ inv1l (delformRight x lt k v rt))
and del_inv1_inv2:
[| inv2 lt; inv1 lt |]
==> inv2 (del x lt) ∧
(treec lt = R ∧ bh (del x lt) = bh lt ∧ inv1 (del x lt) ∨
treec lt = B ∧ bh (del x lt) = bh lt - 1 ∧ inv1l (del x lt))
lemma delformLeft_tlt:
[| lt |« v; rt |« v; k < v |] ==> delformLeft x lt k y rt |« v
and delformRight_tlt:
[| lt |« v; rt |« v; k < v |] ==> delformRight x lt k y rt |« v
and del_tlt:
lt |« v ==> del x lt |« v
lemma delformLeft_tgt:
[| v «| lt; v «| rt; v < k |] ==> v «| delformLeft x lt k y rt
and delformRight_tgt:
[| v «| lt; v «| rt; v < k |] ==> v «| delformRight x lt k y rt
and del_tgt:
v «| lt ==> v «| del x lt
lemma
[| st lt; st rt; lt |« k; k «| rt |] ==> st (delformLeft x lt k y rt)
and
[| st lt; st rt; lt |« k; k «| rt |] ==> st (delformRight x lt k y rt)
and del_st:
st lt ==> st (del x lt)
lemma
[| st lt; st rt; lt |« kt; kt «| rt; inv1 lt; inv1 rt; inv2 lt; inv2 rt;
bh lt = bh rt; x < kt |]
==> pin_tree k v (delformLeft x lt kt y rt) =
(False ∨ x ≠ k ∧ pin_tree k v (Tr c lt kt y rt))
and
[| st lt; st rt; lt |« kt; kt «| rt; inv1 lt; inv1 rt; inv2 lt; inv2 rt;
bh lt = bh rt; kt < x |]
==> pin_tree k v (delformRight x lt kt y rt) =
(False ∨ x ≠ k ∧ pin_tree k v (Tr c lt kt y rt))
and del_pit:
[| st t; inv1 t; inv2 t |]
==> pin_tree k v (del x t) = (False ∨ x ≠ k ∧ pin_tree k v t)
theorem delete_isrbt:
isrbt t ==> isrbt (RBT.delete k t)
lemma delete_pit:
isrbt t ==> pin_tree k v (RBT.delete x t) = (x ≠ k ∧ pin_tree k v t)
lemma map_of_delete:
isrbt t ==> RBT.map_of (RBT.delete k t) = RBT.map_of t |` (- {k})
lemma unionwk_st:
st lt ==> st (unionwithkey f lt rt)
theorem unionwk_isrbt:
isrbt lt ==> isrbt (unionwithkey f lt rt)
theorem unionw_isrbt:
isrbt lt ==> isrbt (unionwith f lt rt)
theorem union_isrbt:
isrbt lt ==> isrbt (union lt rt)
lemma union_Tr:
union t (Tr c lt k v rt) = union (union (insrt k v t) lt) rt
lemma map_of_union:
[| isrbt s; st t |] ==> RBT.map_of (union s t) = RBT.map_of s ++ RBT.map_of t
lemma adjustwk_treec:
treec (adjustwithkey f k t) = treec t
lemma adjustwk_inv1:
inv1 (adjustwithkey f k t) = inv1 t
lemma adjustwk_inv2:
inv2 (adjustwithkey f k t) = inv2 t
bh (adjustwithkey f k t) = bh t
lemma adjustwk_tgt:
(k «| adjustwithkey f kk t) = (k «| t)
lemma adjustwk_tlt:
(adjustwithkey f kk t |« k) = (t |« k)
lemma adjustwk_st:
st (adjustwithkey f k t) = st t
theorem adjustwk_isrbt:
isrbt (adjustwithkey f k t) = isrbt t
theorem adjustwithkey_map:
RBT.map_of (adjustwithkey f k t) x =
(if x = k then case RBT.map_of t x of None => None | Some y => Some (f k y)
else RBT.map_of t x)
theorem adjust_isrbt:
isrbt (RBT.adjust f k t) = isrbt t
theorem adjust_map:
RBT.map_of (RBT.adjust f k t) x =
(if x = k then case RBT.map_of t x of None => None | Some y => Some (f y)
else RBT.map_of t x)
theorem mapwk_keys:
keys (mapwithkey f t) = keys t
lemma mapwk_tgt:
(k «| mapwithkey f t) = (k «| t)
lemma mapwk_tlt:
(mapwithkey f t |« k) = (t |« k)
lemma mapwk_st:
st (mapwithkey f t) = st t
lemma mapwk_treec:
treec (mapwithkey f t) = treec t
lemma mapwk_inv1:
inv1 (mapwithkey f t) = inv1 t
lemma mapwk_inv2:
inv2 (mapwithkey f t) = inv2 t
bh (mapwithkey f t) = bh t
theorem mapwk_isrbt:
isrbt (mapwithkey f t) = isrbt t
theorem map_of_mapwk:
RBT.map_of (mapwithkey f t) x = option_map (f x) (RBT.map_of t x)
theorem map_keys:
keys (RBT.map f t) = keys t
theorem map_isrbt:
isrbt (RBT.map f t) = isrbt t
theorem map_of_map:
RBT.map_of (RBT.map f t) = option_map f o RBT.map_of t
lemma fold_alist_fold:
foldwithkey f t x = foldl (λx (k, v). f k v x) x (alist_of t)
lemma alist_pit:
((k, v) ∈ set (alist_of t)) = pin_tree k v t
lemma sorted_alist:
st t ==> sorted (List.map fst (alist_of t))
lemma distinct_alist:
st t ==> distinct (List.map fst (alist_of t))