# HG changeset patch # User Andreas Lochbihler # Date 1334310330 -7200 # Node ID 2ada2be850cb521052764aecaa90030a5f17d6ea # Parent 11a0aa6cc677e84c97ba0a2e098b59b9e6b38f32 move RBT implementation into type class contexts diff -r 11a0aa6cc677 -r 2ada2be850cb src/HOL/Library/RBT.thy --- a/src/HOL/Library/RBT.thy Thu Apr 12 13:47:21 2012 +0200 +++ b/src/HOL/Library/RBT.thy Fri Apr 13 11:45:30 2012 +0200 @@ -35,7 +35,7 @@ subsection {* Primitive operations *} definition lookup :: "('a\linorder, 'b) rbt \ 'a \ 'b" where - [code]: "lookup t = RBT_Impl.lookup (impl_of t)" + [code]: "lookup t = rbt_lookup (impl_of t)" definition empty :: "('a\linorder, 'b) rbt" where "empty = RBT RBT_Impl.Empty" @@ -45,17 +45,17 @@ by (simp add: empty_def RBT_inverse) definition insert :: "'a\linorder \ 'b \ ('a, 'b) rbt \ ('a, 'b) rbt" where - "insert k v t = RBT (RBT_Impl.insert k v (impl_of t))" + "insert k v t = RBT (rbt_insert k v (impl_of t))" lemma impl_of_insert [code abstract]: - "impl_of (insert k v t) = RBT_Impl.insert k v (impl_of t)" + "impl_of (insert k v t) = rbt_insert k v (impl_of t)" by (simp add: insert_def RBT_inverse) definition delete :: "'a\linorder \ ('a, 'b) rbt \ ('a, 'b) rbt" where - "delete k t = RBT (RBT_Impl.delete k (impl_of t))" + "delete k t = RBT (rbt_delete k (impl_of t))" lemma impl_of_delete [code abstract]: - "impl_of (delete k t) = RBT_Impl.delete k (impl_of t)" + "impl_of (delete k t) = rbt_delete k (impl_of t)" by (simp add: delete_def RBT_inverse) definition entries :: "('a\linorder, 'b) rbt \ ('a \ 'b) list" where @@ -65,17 +65,17 @@ [code]: "keys t = RBT_Impl.keys (impl_of t)" definition bulkload :: "('a\linorder \ 'b) list \ ('a, 'b) rbt" where - "bulkload xs = RBT (RBT_Impl.bulkload xs)" + "bulkload xs = RBT (rbt_bulkload xs)" lemma impl_of_bulkload [code abstract]: - "impl_of (bulkload xs) = RBT_Impl.bulkload xs" + "impl_of (bulkload xs) = rbt_bulkload xs" by (simp add: bulkload_def RBT_inverse) definition map_entry :: "'a \ ('b \ 'b) \ ('a\linorder, 'b) rbt \ ('a, 'b) rbt" where - "map_entry k f t = RBT (RBT_Impl.map_entry k f (impl_of t))" + "map_entry k f t = RBT (rbt_map_entry k f (impl_of t))" lemma impl_of_map_entry [code abstract]: - "impl_of (map_entry k f t) = RBT_Impl.map_entry k f (impl_of t)" + "impl_of (map_entry k f t) = rbt_map_entry k f (impl_of t)" by (simp add: map_entry_def RBT_inverse) definition map :: "('a \ 'b \ 'b) \ ('a\linorder, 'b) rbt \ ('a, 'b) rbt" where @@ -98,11 +98,11 @@ subsection {* Abstract lookup properties *} lemma lookup_RBT: - "is_rbt t \ lookup (RBT t) = RBT_Impl.lookup t" + "is_rbt t \ lookup (RBT t) = rbt_lookup t" by (simp add: lookup_def RBT_inverse) lemma lookup_impl_of: - "RBT_Impl.lookup (impl_of t) = lookup t" + "rbt_lookup (impl_of t) = lookup t" by (simp add: lookup_def) lemma entries_impl_of: @@ -119,11 +119,11 @@ lemma lookup_insert [simp]: "lookup (insert k v t) = (lookup t)(k \ v)" - by (simp add: insert_def lookup_RBT lookup_insert lookup_impl_of) + by (simp add: insert_def lookup_RBT rbt_lookup_rbt_insert lookup_impl_of) lemma lookup_delete [simp]: "lookup (delete k t) = (lookup t)(k := None)" - by (simp add: delete_def lookup_RBT RBT_Impl.lookup_delete lookup_impl_of restrict_complement_singleton_eq) + by (simp add: delete_def lookup_RBT rbt_lookup_rbt_delete lookup_impl_of restrict_complement_singleton_eq) lemma map_of_entries [simp]: "map_of (entries t) = lookup t" @@ -131,19 +131,19 @@ lemma entries_lookup: "entries t1 = entries t2 \ lookup t1 = lookup t2" - by (simp add: entries_def lookup_def entries_lookup) + by (simp add: entries_def lookup_def entries_rbt_lookup) lemma lookup_bulkload [simp]: "lookup (bulkload xs) = map_of xs" - by (simp add: bulkload_def lookup_RBT RBT_Impl.lookup_bulkload) + by (simp add: bulkload_def lookup_RBT rbt_lookup_rbt_bulkload) lemma lookup_map_entry [simp]: "lookup (map_entry k f t) = (lookup t)(k := Option.map f (lookup t k))" - by (simp add: map_entry_def lookup_RBT RBT_Impl.lookup_map_entry lookup_impl_of) + by (simp add: map_entry_def lookup_RBT rbt_lookup_rbt_map_entry lookup_impl_of) lemma lookup_map [simp]: "lookup (map f t) k = Option.map (f k) (lookup t k)" - by (simp add: map_def lookup_RBT RBT_Impl.lookup_map lookup_impl_of) + by (simp add: map_def lookup_RBT rbt_lookup_map lookup_impl_of) lemma fold_fold: "fold f t = List.fold (prod_case f) (entries t)" @@ -154,7 +154,7 @@ by (simp add: rbt_eq_iff is_empty_def impl_of_empty split: rbt.split) lemma RBT_lookup_empty [simp]: (*FIXME*) - "RBT_Impl.lookup t = Map.empty \ t = RBT_Impl.Empty" + "rbt_lookup t = Map.empty \ t = RBT_Impl.Empty" by (cases t) (auto simp add: fun_eq_iff) lemma lookup_empty_empty [simp]: @@ -163,7 +163,7 @@ lemma sorted_keys [iff]: "sorted (keys t)" - by (simp add: keys_def RBT_Impl.keys_def sorted_entries) + by (simp add: keys_def RBT_Impl.keys_def rbt_sorted_entries) lemma distinct_keys [iff]: "distinct (keys t)" diff -r 11a0aa6cc677 -r 2ada2be850cb src/HOL/Library/RBT_Impl.thy --- a/src/HOL/Library/RBT_Impl.thy Thu Apr 12 13:47:21 2012 +0200 +++ b/src/HOL/Library/RBT_Impl.thy Fri Apr 13 11:45:30 2012 +0200 @@ -1,4 +1,4 @@ -(* Title: HOL/Library/RBT_Impl.thy +(* Title: RBT_Impl.thy Author: Markus Reiter, TU Muenchen Author: Alexander Krauss, TU Muenchen *) @@ -65,202 +65,221 @@ subsubsection {* Search tree properties *} -definition tree_less :: "'a\order \ ('a, 'b) rbt \ bool" -where - tree_less_prop: "tree_less k t \ (\x\set (keys t). x < k)" +context ord begin -abbreviation tree_less_symbol (infix "|\" 50) -where "t |\ x \ tree_less x t" +definition rbt_less :: "'a \ ('a, 'b) rbt \ bool" +where + rbt_less_prop: "rbt_less k t \ (\x\set (keys t). x < k)" -definition tree_greater :: "'a\order \ ('a, 'b) rbt \ bool" (infix "\|" 50) +abbreviation rbt_less_symbol (infix "|\" 50) +where "t |\ x \ rbt_less x t" + +definition rbt_greater :: "'a \ ('a, 'b) rbt \ bool" (infix "\|" 50) where - tree_greater_prop: "tree_greater k t = (\x\set (keys t). k < x)" + rbt_greater_prop: "rbt_greater k t = (\x\set (keys t). k < x)" -lemma tree_less_simps [simp]: - "tree_less k Empty = True" - "tree_less k (Branch c lt kt v rt) \ kt < k \ tree_less k lt \ tree_less k rt" - by (auto simp add: tree_less_prop) +lemma rbt_less_simps [simp]: + "Empty |\ k = True" + "Branch c lt kt v rt |\ k \ kt < k \ lt |\ k \ rt |\ k" + by (auto simp add: rbt_less_prop) -lemma tree_greater_simps [simp]: - "tree_greater k Empty = True" - "tree_greater k (Branch c lt kt v rt) \ k < kt \ tree_greater k lt \ tree_greater k rt" - by (auto simp add: tree_greater_prop) +lemma rbt_greater_simps [simp]: + "k \| Empty = True" + "k \| (Branch c lt kt v rt) \ k < kt \ k \| lt \ k \| rt" + by (auto simp add: rbt_greater_prop) -lemmas tree_ord_props = tree_less_prop tree_greater_prop +lemmas rbt_ord_props = rbt_less_prop rbt_greater_prop + +lemmas rbt_greater_nit = rbt_greater_prop entry_in_tree_keys +lemmas rbt_less_nit = rbt_less_prop entry_in_tree_keys -lemmas tree_greater_nit = tree_greater_prop entry_in_tree_keys -lemmas tree_less_nit = tree_less_prop entry_in_tree_keys +lemma (in order) + shows rbt_less_eq_trans: "l |\ u \ u \ v \ l |\ v" + and rbt_less_trans: "t |\ x \ x < y \ t |\ y" + and rbt_greater_eq_trans: "u \ v \ v \| r \ u \| r" + and rbt_greater_trans: "x < y \ y \| t \ x \| t" + by (auto simp: rbt_ord_props) -lemma tree_less_eq_trans: "l |\ u \ u \ v \ l |\ v" - and tree_less_trans: "t |\ x \ x < y \ t |\ y" - and tree_greater_eq_trans: "u \ v \ v \| r \ u \| r" - and tree_greater_trans: "x < y \ y \| t \ x \| t" - by (auto simp: tree_ord_props) - -primrec sorted :: "('a::linorder, 'b) rbt \ bool" +primrec rbt_sorted :: "('a, 'b) rbt \ bool" where - "sorted Empty = True" -| "sorted (Branch c l k v r) = (l |\ k \ k \| r \ sorted l \ sorted r)" + "rbt_sorted Empty = True" +| "rbt_sorted (Branch c l k v r) = (l |\ k \ k \| r \ rbt_sorted l \ rbt_sorted r)" + +end -lemma sorted_entries: - "sorted t \ List.sorted (List.map fst (entries t))" +context linorder begin + +lemma rbt_sorted_entries: + "rbt_sorted t \ List.sorted (List.map fst (entries t))" by (induct t) - (force simp: sorted_append sorted_Cons tree_ord_props + (force simp: sorted_append sorted_Cons rbt_ord_props dest!: entry_in_tree_keys)+ lemma distinct_entries: - "sorted t \ distinct (List.map fst (entries t))" + "rbt_sorted t \ distinct (List.map fst (entries t))" by (induct t) - (force simp: sorted_append sorted_Cons tree_ord_props + (force simp: sorted_append sorted_Cons rbt_ord_props dest!: entry_in_tree_keys)+ - subsubsection {* Tree lookup *} -primrec lookup :: "('a\linorder, 'b) rbt \ 'a \ 'b" +primrec (in ord) rbt_lookup :: "('a, 'b) rbt \ 'a \ 'b" where - "lookup Empty k = None" -| "lookup (Branch _ l x y r) k = (if k < x then lookup l k else if x < k then lookup r k else Some y)" + "rbt_lookup Empty k = None" +| "rbt_lookup (Branch _ l x y r) k = + (if k < x then rbt_lookup l k else if x < k then rbt_lookup r k else Some y)" -lemma lookup_keys: "sorted t \ dom (lookup t) = set (keys t)" - by (induct t) (auto simp: dom_def tree_greater_prop tree_less_prop) +lemma rbt_lookup_keys: "rbt_sorted t \ dom (rbt_lookup t) = set (keys t)" + by (induct t) (auto simp: dom_def rbt_greater_prop rbt_less_prop) -lemma dom_lookup_Branch: - "sorted (Branch c t1 k v t2) \ - dom (lookup (Branch c t1 k v t2)) - = Set.insert k (dom (lookup t1) \ dom (lookup t2))" +lemma dom_rbt_lookup_Branch: + "rbt_sorted (Branch c t1 k v t2) \ + dom (rbt_lookup (Branch c t1 k v t2)) + = Set.insert k (dom (rbt_lookup t1) \ dom (rbt_lookup t2))" proof - - assume "sorted (Branch c t1 k v t2)" - moreover from this have "sorted t1" "sorted t2" by simp_all - ultimately show ?thesis by (simp add: lookup_keys) + assume "rbt_sorted (Branch c t1 k v t2)" + moreover from this have "rbt_sorted t1" "rbt_sorted t2" by simp_all + ultimately show ?thesis by (simp add: rbt_lookup_keys) qed -lemma finite_dom_lookup [simp, intro!]: "finite (dom (lookup t))" +lemma finite_dom_rbt_lookup [simp, intro!]: "finite (dom (rbt_lookup t))" proof (induct t) case Empty then show ?case by simp next case (Branch color t1 a b t2) - let ?A = "Set.insert a (dom (lookup t1) \ dom (lookup t2))" - have "dom (lookup (Branch color t1 a b t2)) \ ?A" by (auto split: split_if_asm) - moreover from Branch have "finite (insert a (dom (lookup t1) \ dom (lookup t2)))" by simp + let ?A = "Set.insert a (dom (rbt_lookup t1) \ dom (rbt_lookup t2))" + have "dom (rbt_lookup (Branch color t1 a b t2)) \ ?A" by (auto split: split_if_asm) + moreover from Branch have "finite (insert a (dom (rbt_lookup t1) \ dom (rbt_lookup t2)))" by simp ultimately show ?case by (rule finite_subset) qed -lemma lookup_tree_less[simp]: "t |\ k \ lookup t k = None" +end + +context ord begin + +lemma rbt_lookup_rbt_less[simp]: "t |\ k \ rbt_lookup t k = None" by (induct t) auto -lemma lookup_tree_greater[simp]: "k \| t \ lookup t k = None" +lemma rbt_lookup_rbt_greater[simp]: "k \| t \ rbt_lookup t k = None" by (induct t) auto -lemma lookup_Empty: "lookup Empty = empty" +lemma rbt_lookup_Empty: "rbt_lookup Empty = empty" by (rule ext) simp +end + +context linorder begin + lemma map_of_entries: - "sorted t \ map_of (entries t) = lookup t" + "rbt_sorted t \ map_of (entries t) = rbt_lookup t" proof (induct t) - case Empty thus ?case by (simp add: lookup_Empty) + case Empty thus ?case by (simp add: rbt_lookup_Empty) next case (Branch c t1 k v t2) - have "lookup (Branch c t1 k v t2) = lookup t2 ++ [k\v] ++ lookup t1" + have "rbt_lookup (Branch c t1 k v t2) = rbt_lookup t2 ++ [k\v] ++ rbt_lookup t1" proof (rule ext) fix x - from Branch have SORTED: "sorted (Branch c t1 k v t2)" by simp - let ?thesis = "lookup (Branch c t1 k v t2) x = (lookup t2 ++ [k \ v] ++ lookup t1) x" + from Branch have RBT_SORTED: "rbt_sorted (Branch c t1 k v t2)" by simp + let ?thesis = "rbt_lookup (Branch c t1 k v t2) x = (rbt_lookup t2 ++ [k \ v] ++ rbt_lookup t1) x" - have DOM_T1: "!!k'. k'\dom (lookup t1) \ k>k'" + have DOM_T1: "!!k'. k'\dom (rbt_lookup t1) \ k>k'" proof - fix k' - from SORTED have "t1 |\ k" by simp - with tree_less_prop have "\k'\set (keys t1). k>k'" by auto - moreover assume "k'\dom (lookup t1)" - ultimately show "k>k'" using lookup_keys SORTED by auto + from RBT_SORTED have "t1 |\ k" by simp + with rbt_less_prop have "\k'\set (keys t1). k>k'" by auto + moreover assume "k'\dom (rbt_lookup t1)" + ultimately show "k>k'" using rbt_lookup_keys RBT_SORTED by auto qed - have DOM_T2: "!!k'. k'\dom (lookup t2) \ kdom (rbt_lookup t2) \ k| t2" by simp - with tree_greater_prop have "\k'\set (keys t2). kdom (lookup t2)" - ultimately show "k| t2" by simp + with rbt_greater_prop have "\k'\set (keys t2). kdom (rbt_lookup t2)" + ultimately show "kdom [k\v]" by simp - moreover have "x\dom (lookup t2)" proof - assume "x\dom (lookup t2)" + moreover have "x \ dom (rbt_lookup t2)" + proof + assume "x \ dom (rbt_lookup t2)" with DOM_T2 have "k v] x" by simp - moreover have "x\dom (lookup t1)" proof - assume "x\dom (lookup t1)" + hence "rbt_lookup (Branch c t1 k v t2) x = [k \ v] x" by simp + moreover have "x \ dom (rbt_lookup t1)" + proof + assume "x \ dom (rbt_lookup t1)" with DOM_T1 have "k>x" by blast thus False by simp qed ultimately have ?thesis by (simp add: map_add_upd_left map_add_dom_app_simps) } moreover { assume C: "x>k" - hence "lookup (Branch c t1 k v t2) x = lookup t2 x" by (simp add: less_not_sym[of k x]) + hence "rbt_lookup (Branch c t1 k v t2) x = rbt_lookup t2 x" by (simp add: less_not_sym[of k x]) moreover from C have "x\dom [k\v]" by simp - moreover have "x\dom (lookup t1)" proof - assume "x\dom (lookup t1)" + moreover have "x\dom (rbt_lookup t1)" proof + assume "x\dom (rbt_lookup t1)" with DOM_T1 have "k>x" by simp with C show False by simp qed ultimately have ?thesis by (simp add: map_add_upd_left map_add_dom_app_simps) } ultimately show ?thesis using less_linear by blast qed - also from Branch have "lookup t2 ++ [k \ v] ++ lookup t1 = map_of (entries (Branch c t1 k v t2))" by simp + also from Branch + have "rbt_lookup t2 ++ [k \ v] ++ rbt_lookup t1 = map_of (entries (Branch c t1 k v t2))" by simp finally show ?case by simp qed -lemma lookup_in_tree: "sorted t \ lookup t k = Some v \ (k, v) \ set (entries t)" +lemma rbt_lookup_in_tree: "rbt_sorted t \ rbt_lookup t k = Some v \ (k, v) \ set (entries t)" by (simp add: map_of_entries [symmetric] distinct_entries) lemma set_entries_inject: - assumes sorted: "sorted t1" "sorted t2" + assumes rbt_sorted: "rbt_sorted t1" "rbt_sorted t2" shows "set (entries t1) = set (entries t2) \ entries t1 = entries t2" proof - - from sorted have "distinct (map fst (entries t1))" + from rbt_sorted have "distinct (map fst (entries t1))" "distinct (map fst (entries t2))" by (auto intro: distinct_entries) - with sorted show ?thesis - by (auto intro: map_sorted_distinct_set_unique sorted_entries simp add: distinct_map) + with rbt_sorted show ?thesis + by (auto intro: map_sorted_distinct_set_unique rbt_sorted_entries simp add: distinct_map) qed lemma entries_eqI: - assumes sorted: "sorted t1" "sorted t2" - assumes lookup: "lookup t1 = lookup t2" + assumes rbt_sorted: "rbt_sorted t1" "rbt_sorted t2" + assumes rbt_lookup: "rbt_lookup t1 = rbt_lookup t2" shows "entries t1 = entries t2" proof - - from sorted lookup have "map_of (entries t1) = map_of (entries t2)" + from rbt_sorted rbt_lookup have "map_of (entries t1) = map_of (entries t2)" by (simp add: map_of_entries) - with sorted have "set (entries t1) = set (entries t2)" + with rbt_sorted have "set (entries t1) = set (entries t2)" by (simp add: map_of_inject_set distinct_entries) - with sorted show ?thesis by (simp add: set_entries_inject) + with rbt_sorted show ?thesis by (simp add: set_entries_inject) qed -lemma entries_lookup: - assumes "sorted t1" "sorted t2" - shows "entries t1 = entries t2 \ lookup t1 = lookup t2" +lemma entries_rbt_lookup: + assumes "rbt_sorted t1" "rbt_sorted t2" + shows "entries t1 = entries t2 \ rbt_lookup t1 = rbt_lookup t2" using assms by (auto intro: entries_eqI simp add: map_of_entries [symmetric]) -lemma lookup_from_in_tree: - assumes "sorted t1" "sorted t2" - and "\v. (k\'a\linorder, v) \ set (entries t1) \ (k, v) \ set (entries t2)" - shows "lookup t1 k = lookup t2 k" +lemma rbt_lookup_from_in_tree: + assumes "rbt_sorted t1" "rbt_sorted t2" + and "\v. (k, v) \ set (entries t1) \ (k, v) \ set (entries t2)" + shows "rbt_lookup t1 k = rbt_lookup t2 k" proof - - from assms have "k \ dom (lookup t1) \ k \ dom (lookup t2)" - by (simp add: keys_entries lookup_keys) - with assms show ?thesis by (auto simp add: lookup_in_tree [symmetric]) + from assms have "k \ dom (rbt_lookup t1) \ k \ dom (rbt_lookup t2)" + by (simp add: keys_entries rbt_lookup_keys) + with assms show ?thesis by (auto simp add: rbt_lookup_in_tree [symmetric]) qed +end subsubsection {* Red-black properties *} @@ -290,15 +309,18 @@ "inv2 Empty = True" | "inv2 (Branch c lt k v rt) = (inv2 lt \ inv2 rt \ bheight lt = bheight rt)" -definition is_rbt :: "('a\linorder, 'b) rbt \ bool" where - "is_rbt t \ inv1 t \ inv2 t \ color_of t = B \ sorted t" +context ord begin -lemma is_rbt_sorted [simp]: - "is_rbt t \ sorted t" by (simp add: is_rbt_def) +definition is_rbt :: "('a, 'b) rbt \ bool" where + "is_rbt t \ inv1 t \ inv2 t \ color_of t = B \ rbt_sorted t" + +lemma is_rbt_rbt_sorted [simp]: + "is_rbt t \ rbt_sorted t" by (simp add: is_rbt_def) theorem Empty_is_rbt [simp]: "is_rbt Empty" by (simp add: is_rbt_def) +end subsection {* Insertion *} @@ -324,61 +346,65 @@ using assms by (induct l k v r rule: balance.induct) auto -lemma balance_tree_greater[simp]: "(v \| balance a k x b) = (v \| a \ v \| b \ v < k)" +context ord begin + +lemma balance_rbt_greater[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_tree_less[simp]: "(balance a k x b |\ v) = (a |\ v \ b |\ v \ k < v)" +lemma balance_rbt_less[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_sorted: - fixes k :: "'a::linorder" - assumes "sorted l" "sorted r" "l |\ k" "k \| r" - shows "sorted (balance l k v r)" +end + +lemma (in linorder) balance_rbt_sorted: + fixes k :: "'a" + assumes "rbt_sorted l" "rbt_sorted r" "l |\ k" "k \| r" + shows "rbt_sorted (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 \| Branch B va vb vd vc" - by (auto simp add: tree_ord_props) - hence "tree_greater y (Branch B va vb vd vc)" by (blast dest: tree_greater_trans) + by (auto simp add: rbt_ord_props) + hence "y \| (Branch B va vb vd vc)" by (blast dest: rbt_greater_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 \ tree_less x (Branch B va vb vd vc)" + from "3_2" have "x < y \ Branch B va vb vd vc |\ x" by simp - hence "tree_less y (Branch B va vb vd vc)" by (blast dest: tree_less_trans) + hence "Branch B va vb vd vc |\ y" by (blast dest: rbt_less_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 \ tree_greater z (Branch B va vb vd vc)" by simp - hence "tree_greater y (Branch B va vb vd vc)" by (blast dest: tree_greater_trans) + from "3_3" have "y < z \ z \| Branch B va vb vd vc" by simp + hence "y \| Branch B va vb vd vc" by (blast dest: rbt_greater_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 \ tree_less x (Branch B vd ve vg vf)" by simp - hence 1: "tree_less y (Branch B vd ve vg vf)" by (blast dest: tree_less_trans) - from "3_4" have "y < z \ tree_greater z (Branch B va vb vii vc)" by simp - hence "tree_greater y (Branch B va vb vii vc)" by (blast dest: tree_greater_trans) + hence "x < y \ Branch B vd ve vg vf |\ x" by simp + hence 1: "Branch B vd ve vg vf |\ y" by (blast dest: rbt_less_trans) + from "3_4" have "y < z \ z \| Branch B va vb vii vc" by simp + hence "y \| Branch B va vb vii vc" by (blast dest: rbt_greater_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 \ tree_less x (Branch B va vb vd vc)" by simp - hence "tree_less y (Branch B va vb vd vc)" by (blast dest: tree_less_trans) + hence "x < y \ Branch B va vb vd vc |\ x" by simp + hence "Branch B va vb vd vc |\ y" by (blast dest: rbt_less_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 \ tree_greater z (Branch B va vb vd vc)" by simp - hence "tree_greater y (Branch B va vb vd vc)" by (blast dest: tree_greater_trans) + hence "y < z \ z \| Branch B va vb vd vc" by simp + hence "y \| Branch B va vb vd vc" by (blast dest: rbt_greater_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 \ tree_less x (Branch B va vb vd vc)" by simp - hence "tree_less y (Branch B va vb vd vc)" by (blast dest: tree_less_trans) + hence "x < y \ Branch B va vb vd vc |\ x" by simp + hence "Branch B va vb vd vc |\ y" by (blast dest: rbt_less_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 \ tree_less x (Branch B va vb vg vc)" by simp - hence 1: "tree_less y (Branch B va vb vg vc)" by (blast dest: tree_less_trans) - from "5_4" have "y < z \ tree_greater z (Branch B vd ve vii vf)" by simp - hence "tree_greater y (Branch B vd ve vii vf)" by (blast dest: tree_greater_trans) + hence "x < y \ Branch B va vb vg vc |\ x" by simp + hence 1: "Branch B va vb vg vc |\ y" by (blast dest: rbt_less_trans) + from "5_4" have "y < z \ z \| Branch B vd ve vii vf" by simp + hence "y \| Branch B vd ve vii vf" by (blast dest: rbt_greater_trans) with 1 "5_4" show ?case by simp qed simp+ @@ -394,11 +420,11 @@ "entry_in_tree k x (balance l v y r) \ entry_in_tree k x l \ k = v \ x = y \ entry_in_tree k x r" by (auto simp add: keys_def) -lemma lookup_balance[simp]: -fixes k :: "'a::linorder" -assumes "sorted l" "sorted r" "l |\ k" "k \| r" -shows "lookup (balance l k v r) x = lookup (Branch B l k v r) x" -by (rule lookup_from_in_tree) (auto simp:assms balance_in_tree balance_sorted) +lemma (in linorder) rbt_lookup_balance[simp]: +fixes k :: "'a" +assumes "rbt_sorted l" "rbt_sorted r" "l |\ k" "k \| r" +shows "rbt_lookup (balance l k v r) x = rbt_lookup (Branch B l k v r) x" +by (rule rbt_lookup_from_in_tree) (auto simp:assms balance_in_tree balance_rbt_sorted) primrec paint :: "color \ ('a,'b) rbt \ ('a,'b) rbt" where @@ -409,95 +435,112 @@ 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_color_of[simp]: "color_of (paint B t) = B" by (cases t) auto -lemma paint_sorted[simp]: "sorted t \ sorted (paint c t)" by (cases t) auto lemma paint_in_tree[simp]: "entry_in_tree k x (paint c t) = entry_in_tree k x t" by (cases t) auto -lemma paint_lookup[simp]: "lookup (paint c t) = lookup t" by (rule ext) (cases t, auto) -lemma paint_tree_greater[simp]: "(v \| paint c t) = (v \| t)" by (cases t) auto -lemma paint_tree_less[simp]: "(paint c t |\ v) = (t |\ v)" by (cases t) auto + +context ord begin + +lemma paint_rbt_sorted[simp]: "rbt_sorted t \ rbt_sorted (paint c t)" by (cases t) auto +lemma paint_rbt_lookup[simp]: "rbt_lookup (paint c t) = rbt_lookup t" by (rule ext) (cases t, auto) +lemma paint_rbt_greater[simp]: "(v \| paint c t) = (v \| t)" by (cases t) auto +lemma paint_rbt_less[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" + rbt_ins :: "('a \ 'b \ 'b \ 'b) \ 'a \ 'b \ ('a,'b) rbt \ ('a,'b) rbt" where - "ins f k v Empty = Branch R Empty k v Empty" | - "ins f k v (Branch 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 Branch B l x (f k y v) r)" | - "ins f k v (Branch R l x y r) = (if k < x then Branch R (ins f k v l) x y r - else if k > x then Branch R l x y (ins f k v r) - else Branch R l x (f k y v) r)" + "rbt_ins f k v Empty = Branch R Empty k v Empty" | + "rbt_ins f k v (Branch B l x y r) = (if k < x then balance (rbt_ins f k v l) x y r + else if k > x then balance l x y (rbt_ins f k v r) + else Branch B l x (f k y v) r)" | + "rbt_ins f k v (Branch R l x y r) = (if k < x then Branch R (rbt_ins f k v l) x y r + else if k > x then Branch R l x y (rbt_ins f k v r) + else Branch R l x (f k y v) r)" lemma ins_inv1_inv2: assumes "inv1 t" "inv2 t" - shows "inv2 (ins f k x t)" "bheight (ins f k x t) = bheight t" - "color_of t = B \ inv1 (ins f k x t)" "inv1l (ins f k x t)" + shows "inv2 (rbt_ins f k x t)" "bheight (rbt_ins f k x t) = bheight t" + "color_of t = B \ inv1 (rbt_ins f k x t)" "inv1l (rbt_ins f k x t)" using assms - by (induct f k x t rule: ins.induct) (auto simp: balance_inv1 balance_inv2 balance_bheight) + by (induct f k x t rule: rbt_ins.induct) (auto simp: balance_inv1 balance_inv2 balance_bheight) + +end + +context linorder begin -lemma ins_tree_greater[simp]: "(v \| ins f k x t) = (v \| t \ k > v)" - by (induct f k x t rule: ins.induct) auto -lemma ins_tree_less[simp]: "(ins f k x t |\ v) = (t |\ v \ k < v)" - by (induct f k x t rule: ins.induct) auto -lemma ins_sorted[simp]: "sorted t \ sorted (ins f k x t)" - by (induct f k x t rule: ins.induct) (auto simp: balance_sorted) +lemma ins_rbt_greater[simp]: "(v \| rbt_ins f (k :: 'a) x t) = (v \| t \ k > v)" + by (induct f k x t rule: rbt_ins.induct) auto +lemma ins_rbt_less[simp]: "(rbt_ins f k x t |\ v) = (t |\ v \ k < v)" + by (induct f k x t rule: rbt_ins.induct) auto +lemma ins_rbt_sorted[simp]: "rbt_sorted t \ rbt_sorted (rbt_ins f k x t)" + by (induct f k x t rule: rbt_ins.induct) (auto simp: balance_rbt_sorted) -lemma keys_ins: "set (keys (ins f k v t)) = { k } \ set (keys t)" - by (induct f k v t rule: ins.induct) auto +lemma keys_ins: "set (keys (rbt_ins f k v t)) = { k } \ set (keys t)" + by (induct f k v t rule: rbt_ins.induct) auto -lemma lookup_ins: - fixes k :: "'a::linorder" - assumes "sorted t" - shows "lookup (ins f k v t) x = ((lookup t)(k |-> case lookup t k of None \ v - | Some w \ f k w v)) x" -using assms by (induct f k v t rule: ins.induct) auto +lemma rbt_lookup_ins: + fixes k :: "'a" + assumes "rbt_sorted t" + shows "rbt_lookup (rbt_ins f k v t) x = ((rbt_lookup t)(k |-> case rbt_lookup t k of None \ v + | Some w \ f k w v)) x" +using assms by (induct f k v t rule: rbt_ins.induct) auto + +end + +context ord begin + +definition rbt_insert_with_key :: "('a \ 'b \ 'b \ 'b) \ 'a \ 'b \ ('a,'b) rbt \ ('a,'b) rbt" +where "rbt_insert_with_key f k v t = paint B (rbt_ins f k v t)" + +definition rbt_insertw_def: "rbt_insert_with f = rbt_insert_with_key (\_. f)" -definition - insert_with_key :: "('a\linorder \ 'b \ 'b \ 'b) \ 'a \ 'b \ ('a,'b) rbt \ ('a,'b) rbt" -where - "insert_with_key f k v t = paint B (ins f k v t)" +definition rbt_insert :: "'a \ 'b \ ('a, 'b) rbt \ ('a, 'b) rbt" where + "rbt_insert = rbt_insert_with_key (\_ _ nv. nv)" + +end + +context linorder begin -lemma insertwk_sorted: "sorted t \ sorted (insert_with_key f k x t)" - by (auto simp: insert_with_key_def) +lemma rbt_insertwk_rbt_sorted: "rbt_sorted t \ rbt_sorted (rbt_insert_with_key f (k :: 'a) x t)" + by (auto simp: rbt_insert_with_key_def) -theorem insertwk_is_rbt: +theorem rbt_insertwk_is_rbt: assumes inv: "is_rbt t" - shows "is_rbt (insert_with_key f k x t)" + shows "is_rbt (rbt_insert_with_key f k x t)" using assms -unfolding insert_with_key_def is_rbt_def +unfolding rbt_insert_with_key_def is_rbt_def by (auto simp: ins_inv1_inv2) -lemma lookup_insertwk: - assumes "sorted t" - shows "lookup (insert_with_key f k v t) x = ((lookup t)(k |-> case lookup t k of None \ v +lemma rbt_lookup_rbt_insertwk: + assumes "rbt_sorted t" + shows "rbt_lookup (rbt_insert_with_key f k v t) x = ((rbt_lookup t)(k |-> case rbt_lookup t k of None \ v | Some w \ f k w v)) x" -unfolding insert_with_key_def using assms -by (simp add:lookup_ins) +unfolding rbt_insert_with_key_def using assms +by (simp add:rbt_lookup_ins) -definition - insertw_def: "insert_with f = insert_with_key (\_. f)" +lemma rbt_insertw_rbt_sorted: "rbt_sorted t \ rbt_sorted (rbt_insert_with f k v t)" + by (simp add: rbt_insertwk_rbt_sorted rbt_insertw_def) +theorem rbt_insertw_is_rbt: "is_rbt t \ is_rbt (rbt_insert_with f k v t)" + by (simp add: rbt_insertwk_is_rbt rbt_insertw_def) -lemma insertw_sorted: "sorted t \ sorted (insert_with f k v t)" by (simp add: insertwk_sorted insertw_def) -theorem insertw_is_rbt: "is_rbt t \ is_rbt (insert_with f k v t)" by (simp add: insertwk_is_rbt insertw_def) - -lemma lookup_insertw: +lemma rbt_lookup_rbt_insertw: assumes "is_rbt t" - shows "lookup (insert_with f k v t) = (lookup t)(k \ (if k:dom (lookup t) then f (the (lookup t k)) v else v))" + shows "rbt_lookup (rbt_insert_with f k v t) = (rbt_lookup t)(k \ (if k:dom (rbt_lookup t) then f (the (rbt_lookup t k)) v else v))" using assms -unfolding insertw_def -by (rule_tac ext) (cases "lookup t k", auto simp:lookup_insertwk dom_def) +unfolding rbt_insertw_def +by (rule_tac ext) (cases "rbt_lookup t k", auto simp:rbt_lookup_rbt_insertwk dom_def) -definition insert :: "'a\linorder \ 'b \ ('a, 'b) rbt \ ('a, 'b) rbt" where - "insert = insert_with_key (\_ _ nv. nv)" +lemma rbt_insert_rbt_sorted: "rbt_sorted t \ rbt_sorted (rbt_insert k v t)" + by (simp add: rbt_insertwk_rbt_sorted rbt_insert_def) +theorem rbt_insert_is_rbt [simp]: "is_rbt t \ is_rbt (rbt_insert k v t)" + by (simp add: rbt_insertwk_is_rbt rbt_insert_def) -lemma insert_sorted: "sorted t \ sorted (insert k v t)" by (simp add: insertwk_sorted insert_def) -theorem insert_is_rbt [simp]: "is_rbt t \ is_rbt (insert k v t)" by (simp add: insertwk_is_rbt insert_def) - -lemma lookup_insert: +lemma rbt_lookup_rbt_insert: assumes "is_rbt t" - shows "lookup (insert k v t) = (lookup t)(k\v)" -unfolding insert_def + shows "rbt_lookup (rbt_insert k v t) = (rbt_lookup t)(k\v)" +unfolding rbt_insert_def using assms -by (rule_tac ext) (simp add: lookup_insertwk split:option.split) +by (rule_tac ext) (simp add: rbt_lookup_rbt_insertwk split:option.split) +end subsection {* Deletion *} @@ -532,26 +575,31 @@ lemma balance_left_inv1l: "\ inv1l lt; inv1 rt \ \ inv1l (balance_left lt k x rt)" by (induct lt k x rt rule: balance_left.induct) (auto simp: balance_inv1) -lemma balance_left_sorted: "\ sorted l; sorted r; tree_less k l; tree_greater k r \ \ sorted (balance_left l k v r)" +lemma (in linorder) balance_left_rbt_sorted: + "\ rbt_sorted l; rbt_sorted r; rbt_less k l; k \| r \ \ rbt_sorted (balance_left l k v r)" apply (induct l k v r rule: balance_left.induct) -apply (auto simp: balance_sorted) -apply (unfold tree_greater_prop tree_less_prop) +apply (auto simp: balance_rbt_sorted) +apply (unfold rbt_greater_prop rbt_less_prop) by force+ -lemma balance_left_tree_greater: - fixes k :: "'a::order" +context order begin + +lemma balance_left_rbt_greater: + fixes k :: "'a" assumes "k \| a" "k \| b" "k < x" shows "k \| balance_left a x t b" using assms by (induct a x t b rule: balance_left.induct) auto -lemma balance_left_tree_less: - fixes k :: "'a::order" +lemma balance_left_rbt_less: + fixes k :: "'a" assumes "a |\ k" "b |\ k" "x < k" shows "balance_left a x t b |\ k" using assms by (induct a x t b rule: balance_left.induct) auto +end + lemma balance_left_in_tree: assumes "inv1l l" "inv1 r" "bheight l + 1 = bheight r" shows "entry_in_tree k v (balance_left l a b r) = (entry_in_tree k v l \ k = a \ v = b \ entry_in_tree k v r)" @@ -578,24 +626,29 @@ lemma balance_right_inv1l: "\ inv1 lt; inv1l rt \ \inv1l (balance_right lt k x rt)" by (induct lt k x rt rule: balance_right.induct) (auto simp: balance_inv1) -lemma balance_right_sorted: "\ sorted l; sorted r; tree_less k l; tree_greater k r \ \ sorted (balance_right l k v r)" +lemma (in linorder) balance_right_rbt_sorted: + "\ rbt_sorted l; rbt_sorted r; rbt_less k l; k \| r \ \ rbt_sorted (balance_right l k v r)" apply (induct l k v r rule: balance_right.induct) -apply (auto simp:balance_sorted) -apply (unfold tree_less_prop tree_greater_prop) +apply (auto simp:balance_rbt_sorted) +apply (unfold rbt_less_prop rbt_greater_prop) by force+ -lemma balance_right_tree_greater: - fixes k :: "'a::order" +context order begin + +lemma balance_right_rbt_greater: + fixes k :: "'a" assumes "k \| a" "k \| b" "k < x" shows "k \| balance_right a x t b" using assms by (induct a x t b rule: balance_right.induct) auto -lemma balance_right_tree_less: - fixes k :: "'a::order" +lemma balance_right_rbt_less: + fixes k :: "'a" assumes "a |\ k" "b |\ k" "x < k" shows "balance_right a x t b |\ k" using assms by (induct a x t b rule: balance_right.induct) auto +end + lemma balance_right_in_tree: assumes "inv1 l" "inv1l r" "bheight l = bheight r + 1" "inv2 l" "inv2 r" shows "entry_in_tree x y (balance_right l k v r) = (entry_in_tree x y l \ x = k \ y = v \ entry_in_tree x y r)" @@ -607,11 +660,11 @@ "combine Empty x = x" | "combine x Empty = x" | "combine (Branch R a k x b) (Branch R c s y d) = (case (combine b c) of - Branch R b2 t z c2 \ (Branch R (Branch R a k x b2) t z (Branch R c2 s y d)) | - bc \ Branch R a k x (Branch R bc s y d))" + Branch R b2 t z c2 \ (Branch R (Branch R a k x b2) t z (Branch R c2 s y d)) | + bc \ Branch R a k x (Branch R bc s y d))" | "combine (Branch B a k x b) (Branch B c s y d) = (case (combine b c) of - Branch R b2 t z c2 \ Branch R (Branch B a k x b2) t z (Branch B c2 s y d) | - bc \ balance_left a k x (Branch B bc s y d))" + Branch R b2 t z c2 \ Branch R (Branch B a k x b2) t z (Branch B c2 s y d) | + bc \ balance_left a k x (Branch B bc s y d))" | "combine a (Branch R b k x c) = Branch R (combine a b) k x c" | "combine (Branch R a k x b) c = Branch R a k x (combine b c)" @@ -630,26 +683,28 @@ by (induct lt rt rule: combine.induct) (auto simp: balance_left_inv1 split: rbt.splits color.splits) -lemma combine_tree_greater[simp]: - fixes k :: "'a::linorder" +context linorder begin + +lemma combine_rbt_greater[simp]: + fixes k :: "'a" assumes "k \| l" "k \| r" shows "k \| combine l r" using assms by (induct l r rule: combine.induct) - (auto simp: balance_left_tree_greater split:rbt.splits color.splits) + (auto simp: balance_left_rbt_greater split:rbt.splits color.splits) -lemma combine_tree_less[simp]: - fixes k :: "'a::linorder" +lemma combine_rbt_less[simp]: + fixes k :: "'a" assumes "l |\ k" "r |\ k" shows "combine l r |\ k" using assms by (induct l r rule: combine.induct) - (auto simp: balance_left_tree_less split:rbt.splits color.splits) + (auto simp: balance_left_rbt_less split:rbt.splits color.splits) -lemma combine_sorted: - fixes k :: "'a::linorder" - assumes "sorted l" "sorted r" "l |\ k" "k \| r" - shows "sorted (combine l r)" +lemma combine_rbt_sorted: + fixes k :: "'a" + assumes "rbt_sorted l" "rbt_sorted r" "l |\ k" "k \| r" + shows "rbt_sorted (combine l r)" using assms proof (induct l r rule: combine.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" @@ -657,48 +712,52 @@ with 3 show ?case by (cases "combine b c" rule: rbt_cases) - (auto, (metis combine_tree_greater combine_tree_less ineqs ineqs tree_less_simps(2) tree_greater_simps(2) tree_greater_trans tree_less_trans)+) + (auto, (metis combine_rbt_greater combine_rbt_less ineqs ineqs rbt_less_simps(2) rbt_greater_simps(2) rbt_greater_trans rbt_less_trans)+) next case (4 a x v b c y w d) - hence "x < k \ tree_greater k c" by simp - hence "tree_greater x c" by (blast dest: tree_greater_trans) - with 4 have 2: "tree_greater x (combine b c)" by (simp add: combine_tree_greater) - from 4 have "k < y \ tree_less k b" by simp - hence "tree_less y b" by (blast dest: tree_less_trans) - with 4 have 3: "tree_less y (combine b c)" by (simp add: combine_tree_less) + hence "x < k \ rbt_greater k c" by simp + hence "rbt_greater x c" by (blast dest: rbt_greater_trans) + with 4 have 2: "rbt_greater x (combine b c)" by (simp add: combine_rbt_greater) + from 4 have "k < y \ rbt_less k b" by simp + hence "rbt_less y b" by (blast dest: rbt_less_trans) + with 4 have 3: "rbt_less y (combine b c)" by (simp add: combine_rbt_less) show ?case proof (cases "combine b c" rule: rbt_cases) case Empty - from 4 have "x < y \ tree_greater y d" by auto - hence "tree_greater x d" by (blast dest: tree_greater_trans) - with 4 Empty have "sorted a" and "sorted (Branch B Empty y w d)" and "tree_less x a" and "tree_greater x (Branch B Empty y w d)" by auto - with Empty show ?thesis by (simp add: balance_left_sorted) + from 4 have "x < y \ rbt_greater y d" by auto + hence "rbt_greater x d" by (blast dest: rbt_greater_trans) + with 4 Empty have "rbt_sorted a" and "rbt_sorted (Branch B Empty y w d)" + and "rbt_less x a" and "rbt_greater x (Branch B Empty y w d)" by auto + with Empty show ?thesis by (simp add: balance_left_rbt_sorted) next case (Red lta va ka rta) - with 2 4 have "x < va \ tree_less x a" by simp - hence 5: "tree_less va a" by (blast dest: tree_less_trans) - from Red 3 4 have "va < y \ tree_greater y d" by simp - hence "tree_greater va d" by (blast dest: tree_greater_trans) + with 2 4 have "x < va \ rbt_less x a" by simp + hence 5: "rbt_less va a" by (blast dest: rbt_less_trans) + from Red 3 4 have "va < y \ rbt_greater y d" by simp + hence "rbt_greater va d" by (blast dest: rbt_greater_trans) with Red 2 3 4 5 show ?thesis by simp next case (Black lta va ka rta) - from 4 have "x < y \ tree_greater y d" by auto - hence "tree_greater x d" by (blast dest: tree_greater_trans) - with Black 2 3 4 have "sorted a" and "sorted (Branch B (combine b c) y w d)" and "tree_less x a" and "tree_greater x (Branch B (combine b c) y w d)" by auto - with Black show ?thesis by (simp add: balance_left_sorted) + from 4 have "x < y \ rbt_greater y d" by auto + hence "rbt_greater x d" by (blast dest: rbt_greater_trans) + with Black 2 3 4 have "rbt_sorted a" and "rbt_sorted (Branch B (combine b c) y w d)" + and "rbt_less x a" and "rbt_greater x (Branch B (combine b c) y w d)" by auto + with Black show ?thesis by (simp add: balance_left_rbt_sorted) qed next case (5 va vb vd vc b x w c) - hence "k < x \ tree_less k (Branch B va vb vd vc)" by simp - hence "tree_less x (Branch B va vb vd vc)" by (blast dest: tree_less_trans) - with 5 show ?case by (simp add: combine_tree_less) + hence "k < x \ rbt_less k (Branch B va vb vd vc)" by simp + hence "rbt_less x (Branch B va vb vd vc)" by (blast dest: rbt_less_trans) + with 5 show ?case by (simp add: combine_rbt_less) next case (6 a x v b va vb vd vc) - hence "x < k \ tree_greater k (Branch B va vb vd vc)" by simp - hence "tree_greater x (Branch B va vb vd vc)" by (blast dest: tree_greater_trans) - with 6 show ?case by (simp add: combine_tree_greater) + hence "x < k \ rbt_greater k (Branch B va vb vd vc)" by simp + hence "rbt_greater x (Branch B va vb vd vc)" by (blast dest: rbt_greater_trans) + with 6 show ?case by (simp add: combine_rbt_greater) qed simp+ +end + lemma combine_in_tree: assumes "inv2 l" "inv2 r" "bheight l = bheight r" "inv1 l" "inv1 r" shows "entry_in_tree k v (combine l r) = (entry_in_tree k v l \ entry_in_tree k v r)" @@ -721,29 +780,43 @@ qed qed (auto split: rbt.splits color.splits) +context ord begin + fun - del_from_left :: "('a\linorder) \ ('a,'b) rbt \ 'a \ 'b \ ('a,'b) rbt \ ('a,'b) rbt" and - del_from_right :: "('a\linorder) \ ('a,'b) rbt \ 'a \ 'b \ ('a,'b) rbt \ ('a,'b) rbt" and - del :: "('a\linorder) \ ('a,'b) rbt \ ('a,'b) rbt" + rbt_del_from_left :: "'a \ ('a,'b) rbt \ 'a \ 'b \ ('a,'b) rbt \ ('a,'b) rbt" and + rbt_del_from_right :: "'a \ ('a,'b) rbt \ 'a \ 'b \ ('a,'b) rbt \ ('a,'b) rbt" and + rbt_del :: "'a\ ('a,'b) rbt \ ('a,'b) rbt" where - "del x Empty = Empty" | - "del x (Branch c a y s b) = (if x < y then del_from_left x a y s b else (if x > y then del_from_right x a y s b else combine a b))" | - "del_from_left x (Branch B lt z v rt) y s b = balance_left (del x (Branch B lt z v rt)) y s b" | - "del_from_left x a y s b = Branch R (del x a) y s b" | - "del_from_right x a y s (Branch B lt z v rt) = balance_right a y s (del x (Branch B lt z v rt))" | - "del_from_right x a y s b = Branch R a y s (del x b)" + "rbt_del x Empty = Empty" | + "rbt_del x (Branch c a y s b) = + (if x < y then rbt_del_from_left x a y s b + else (if x > y then rbt_del_from_right x a y s b else combine a b))" | + "rbt_del_from_left x (Branch B lt z v rt) y s b = balance_left (rbt_del x (Branch B lt z v rt)) y s b" | + "rbt_del_from_left x a y s b = Branch R (rbt_del x a) y s b" | + "rbt_del_from_right x a y s (Branch B lt z v rt) = balance_right a y s (rbt_del x (Branch B lt z v rt))" | + "rbt_del_from_right x a y s b = Branch R a y s (rbt_del x b)" + +end + +context linorder begin lemma assumes "inv2 lt" "inv1 lt" shows "\inv2 rt; bheight lt = bheight rt; inv1 rt\ \ - inv2 (del_from_left x lt k v rt) \ bheight (del_from_left x lt k v rt) = bheight lt \ (color_of lt = B \ color_of rt = B \ inv1 (del_from_left x lt k v rt) \ (color_of lt \ B \ color_of rt \ B) \ inv1l (del_from_left x lt k v rt))" + inv2 (rbt_del_from_left x lt k v rt) \ + bheight (rbt_del_from_left x lt k v rt) = bheight lt \ + (color_of lt = B \ color_of rt = B \ inv1 (rbt_del_from_left x lt k v rt) \ + (color_of lt \ B \ color_of rt \ B) \ inv1l (rbt_del_from_left x lt k v rt))" and "\inv2 rt; bheight lt = bheight rt; inv1 rt\ \ - inv2 (del_from_right x lt k v rt) \ bheight (del_from_right x lt k v rt) = bheight lt \ (color_of lt = B \ color_of rt = B \ inv1 (del_from_right x lt k v rt) \ (color_of lt \ B \ color_of rt \ B) \ inv1l (del_from_right x lt k v rt))" - and del_inv1_inv2: "inv2 (del x lt) \ (color_of lt = R \ bheight (del x lt) = bheight lt \ inv1 (del x lt) - \ color_of lt = B \ bheight (del x lt) = bheight lt - 1 \ inv1l (del x lt))" + inv2 (rbt_del_from_right x lt k v rt) \ + bheight (rbt_del_from_right x lt k v rt) = bheight lt \ + (color_of lt = B \ color_of rt = B \ inv1 (rbt_del_from_right x lt k v rt) \ + (color_of lt \ B \ color_of rt \ B) \ inv1l (rbt_del_from_right x lt k v rt))" + and rbt_del_inv1_inv2: "inv2 (rbt_del x lt) \ (color_of lt = R \ bheight (rbt_del x lt) = bheight lt \ inv1 (rbt_del x lt) + \ color_of lt = B \ bheight (rbt_del x lt) = bheight lt - 1 \ inv1l (rbt_del x lt))" using assms -proof (induct x lt k v rt and x lt k v rt and x lt rule: del_from_left_del_from_right_del.induct) +proof (induct x lt k v rt and x lt k v rt and x lt rule: rbt_del_from_left_rbt_del_from_right_rbt_del.induct) case (2 y c _ y') have "y = y' \ y < y' \ y > y'" by auto thus ?case proof (elim disjE) @@ -767,55 +840,55 @@ qed auto lemma - del_from_left_tree_less: "\tree_less v lt; tree_less v rt; k < v\ \ tree_less v (del_from_left x lt k y rt)" - and del_from_right_tree_less: "\tree_less v lt; tree_less v rt; k < v\ \ tree_less v (del_from_right x lt k y rt)" - and del_tree_less: "tree_less v lt \ tree_less v (del x lt)" -by (induct x lt k y rt and x lt k y rt and x lt rule: del_from_left_del_from_right_del.induct) - (auto simp: balance_left_tree_less balance_right_tree_less) + rbt_del_from_left_rbt_less: "\ lt |\ v; rt |\ v; k < v\ \ rbt_del_from_left x lt k y rt |\ v" + and rbt_del_from_right_rbt_less: "\lt |\ v; rt |\ v; k < v\ \ rbt_del_from_right x lt k y rt |\ v" + and rbt_del_rbt_less: "lt |\ v \ rbt_del x lt |\ v" +by (induct x lt k y rt and x lt k y rt and x lt rule: rbt_del_from_left_rbt_del_from_right_rbt_del.induct) + (auto simp: balance_left_rbt_less balance_right_rbt_less) -lemma del_from_left_tree_greater: "\tree_greater v lt; tree_greater v rt; k > v\ \ tree_greater v (del_from_left x lt k y rt)" - and del_from_right_tree_greater: "\tree_greater v lt; tree_greater v rt; k > v\ \ tree_greater v (del_from_right x lt k y rt)" - and del_tree_greater: "tree_greater v lt \ tree_greater v (del x lt)" -by (induct x lt k y rt and x lt k y rt and x lt rule: del_from_left_del_from_right_del.induct) - (auto simp: balance_left_tree_greater balance_right_tree_greater) +lemma rbt_del_from_left_rbt_greater: "\v \| lt; v \| rt; k > v\ \ v \| rbt_del_from_left x lt k y rt" + and rbt_del_from_right_rbt_greater: "\v \| lt; v \| rt; k > v\ \ v \| rbt_del_from_right x lt k y rt" + and rbt_del_rbt_greater: "v \| lt \ v \| rbt_del x lt" +by (induct x lt k y rt and x lt k y rt and x lt rule: rbt_del_from_left_rbt_del_from_right_rbt_del.induct) + (auto simp: balance_left_rbt_greater balance_right_rbt_greater) -lemma "\sorted lt; sorted rt; tree_less k lt; tree_greater k rt\ \ sorted (del_from_left x lt k y rt)" - and "\sorted lt; sorted rt; tree_less k lt; tree_greater k rt\ \ sorted (del_from_right x lt k y rt)" - and del_sorted: "sorted lt \ sorted (del x lt)" -proof (induct x lt k y rt and x lt k y rt and x lt rule: del_from_left_del_from_right_del.induct) +lemma "\rbt_sorted lt; rbt_sorted rt; lt |\ k; k \| rt\ \ rbt_sorted (rbt_del_from_left x lt k y rt)" + and "\rbt_sorted lt; rbt_sorted rt; lt |\ k; k \| rt\ \ rbt_sorted (rbt_del_from_right x lt k y rt)" + and rbt_del_rbt_sorted: "rbt_sorted lt \ rbt_sorted (rbt_del x lt)" +proof (induct x lt k y rt and x lt k y rt and x lt rule: rbt_del_from_left_rbt_del_from_right_rbt_del.induct) case (3 x lta zz v rta yy ss bb) - from 3 have "tree_less yy (Branch B lta zz v rta)" by simp - hence "tree_less yy (del x (Branch B lta zz v rta))" by (rule del_tree_less) - with 3 show ?case by (simp add: balance_left_sorted) + from 3 have "Branch B lta zz v rta |\ yy" by simp + hence "rbt_del x (Branch B lta zz v rta) |\ yy" by (rule rbt_del_rbt_less) + with 3 show ?case by (simp add: balance_left_rbt_sorted) next case ("4_2" x vaa vbb vdd vc yy ss bb) - hence "tree_less yy (Branch R vaa vbb vdd vc)" by simp - hence "tree_less yy (del x (Branch R vaa vbb vdd vc))" by (rule del_tree_less) + hence "Branch R vaa vbb vdd vc |\ yy" by simp + hence "rbt_del x (Branch R vaa vbb vdd vc) |\ yy" by (rule rbt_del_rbt_less) with "4_2" show ?case by simp next case (5 x aa yy ss lta zz v rta) - hence "tree_greater yy (Branch B lta zz v rta)" by simp - hence "tree_greater yy (del x (Branch B lta zz v rta))" by (rule del_tree_greater) - with 5 show ?case by (simp add: balance_right_sorted) + hence "yy \| Branch B lta zz v rta" by simp + hence "yy \| rbt_del x (Branch B lta zz v rta)" by (rule rbt_del_rbt_greater) + with 5 show ?case by (simp add: balance_right_rbt_sorted) next case ("6_2" x aa yy ss vaa vbb vdd vc) - hence "tree_greater yy (Branch R vaa vbb vdd vc)" by simp - hence "tree_greater yy (del x (Branch R vaa vbb vdd vc))" by (rule del_tree_greater) + hence "yy \| Branch R vaa vbb vdd vc" by simp + hence "yy \| rbt_del x (Branch R vaa vbb vdd vc)" by (rule rbt_del_rbt_greater) with "6_2" show ?case by simp -qed (auto simp: combine_sorted) +qed (auto simp: combine_rbt_sorted) -lemma "\sorted lt; sorted rt; tree_less kt lt; tree_greater kt rt; inv1 lt; inv1 rt; inv2 lt; inv2 rt; bheight lt = bheight rt; x < kt\ \ entry_in_tree k v (del_from_left x lt kt y rt) = (False \ (x \ k \ entry_in_tree k v (Branch c lt kt y rt)))" - and "\sorted lt; sorted rt; tree_less kt lt; tree_greater kt rt; inv1 lt; inv1 rt; inv2 lt; inv2 rt; bheight lt = bheight rt; x > kt\ \ entry_in_tree k v (del_from_right x lt kt y rt) = (False \ (x \ k \ entry_in_tree k v (Branch c lt kt y rt)))" - and del_in_tree: "\sorted t; inv1 t; inv2 t\ \ entry_in_tree k v (del x t) = (False \ (x \ k \ entry_in_tree k v t))" -proof (induct x lt kt y rt and x lt kt y rt and x t rule: del_from_left_del_from_right_del.induct) +lemma "\rbt_sorted lt; rbt_sorted rt; lt |\ kt; kt \| rt; inv1 lt; inv1 rt; inv2 lt; inv2 rt; bheight lt = bheight rt; x < kt\ \ entry_in_tree k v (rbt_del_from_left x lt kt y rt) = (False \ (x \ k \ entry_in_tree k v (Branch c lt kt y rt)))" + and "\rbt_sorted lt; rbt_sorted rt; lt |\ kt; kt \| rt; inv1 lt; inv1 rt; inv2 lt; inv2 rt; bheight lt = bheight rt; x > kt\ \ entry_in_tree k v (rbt_del_from_right x lt kt y rt) = (False \ (x \ k \ entry_in_tree k v (Branch c lt kt y rt)))" + and rbt_del_in_tree: "\rbt_sorted t; inv1 t; inv2 t\ \ entry_in_tree k v (rbt_del x t) = (False \ (x \ k \ entry_in_tree k v t))" +proof (induct x lt kt y rt and x lt kt y rt and x t rule: rbt_del_from_left_rbt_del_from_right_rbt_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 "sorted (Branch c aa yy ss bb) \ k = yy" by simp - hence "\ entry_in_tree k v aa" "\ entry_in_tree k v bb" by (auto simp: tree_less_nit tree_greater_prop) + from 2 `xx = yy` `xx = k` have "rbt_sorted (Branch c aa yy ss bb) \ k = yy" by simp + hence "\ entry_in_tree k v aa" "\ entry_in_tree k v bb" by (auto simp: rbt_less_nit rbt_greater_prop) with `xx = yy` 2 `xx = k` show ?thesis by (simp add: combine_in_tree) qed (simp add: combine_in_tree) qed simp+ @@ -823,143 +896,147 @@ case (3 xx lta zz vv rta yy ss bb) def mt[simp]: mt == "Branch B lta zz vv rta" from 3 have "inv2 mt \ inv1 mt" by simp - hence "inv2 (del xx mt) \ (color_of mt = R \ bheight (del xx mt) = bheight mt \ inv1 (del xx mt) \ color_of mt = B \ bheight (del xx mt) = bheight mt - 1 \ inv1l (del xx mt))" by (blast dest: del_inv1_inv2) - with 3 have 4: "entry_in_tree k v (del_from_left xx mt yy ss bb) = (False \ xx \ k \ entry_in_tree k v mt \ (k = yy \ v = ss) \ entry_in_tree k v bb)" by (simp add: balance_left_in_tree) + hence "inv2 (rbt_del xx mt) \ (color_of mt = R \ bheight (rbt_del xx mt) = bheight mt \ inv1 (rbt_del xx mt) \ color_of mt = B \ bheight (rbt_del xx mt) = bheight mt - 1 \ inv1l (rbt_del xx mt))" by (blast dest: rbt_del_inv1_inv2) + with 3 have 4: "entry_in_tree k v (rbt_del_from_left xx mt yy ss bb) = (False \ xx \ k \ entry_in_tree k v mt \ (k = yy \ v = ss) \ entry_in_tree k v bb)" by (simp add: balance_left_in_tree) thus ?case proof (cases "xx = k") case True - from 3 True have "tree_greater yy bb \ yy > k" by simp - hence "tree_greater k bb" by (blast dest: tree_greater_trans) - with 3 4 True show ?thesis by (auto simp: tree_greater_nit) + from 3 True have "yy \| bb \ yy > k" by simp + hence "k \| bb" by (blast dest: rbt_greater_trans) + with 3 4 True show ?thesis by (auto simp: rbt_greater_nit) qed auto next case ("4_1" xx yy ss bb) show ?case proof (cases "xx = k") case True - with "4_1" have "tree_greater yy bb \ k < yy" by simp - hence "tree_greater k bb" by (blast dest: tree_greater_trans) + with "4_1" have "yy \| bb \ k < yy" by simp + hence "k \| bb" by (blast dest: rbt_greater_trans) with "4_1" `xx = k` - have "entry_in_tree k v (Branch R Empty yy ss bb) = entry_in_tree k v Empty" by (auto simp: tree_greater_nit) + have "entry_in_tree k v (Branch R Empty yy ss bb) = entry_in_tree k v Empty" by (auto simp: rbt_greater_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 \ tree_greater yy bb" by simp - hence "tree_greater k bb" by (blast dest: tree_greater_trans) - with True "4_2" show ?thesis by (auto simp: tree_greater_nit) + with "4_2" have "k < yy \ yy \| bb" by simp + hence "k \| bb" by (blast dest: rbt_greater_trans) + with True "4_2" show ?thesis by (auto simp: rbt_greater_nit) qed auto next case (5 xx aa yy ss lta zz vv rta) def mt[simp]: mt == "Branch B lta zz vv rta" from 5 have "inv2 mt \ inv1 mt" by simp - hence "inv2 (del xx mt) \ (color_of mt = R \ bheight (del xx mt) = bheight mt \ inv1 (del xx mt) \ color_of mt = B \ bheight (del xx mt) = bheight mt - 1 \ inv1l (del xx mt))" by (blast dest: del_inv1_inv2) - with 5 have 3: "entry_in_tree k v (del_from_right xx aa yy ss mt) = (entry_in_tree k v aa \ (k = yy \ v = ss) \ False \ xx \ k \ entry_in_tree k v mt)" by (simp add: balance_right_in_tree) + hence "inv2 (rbt_del xx mt) \ (color_of mt = R \ bheight (rbt_del xx mt) = bheight mt \ inv1 (rbt_del xx mt) \ color_of mt = B \ bheight (rbt_del xx mt) = bheight mt - 1 \ inv1l (rbt_del xx mt))" by (blast dest: rbt_del_inv1_inv2) + with 5 have 3: "entry_in_tree k v (rbt_del_from_right xx aa yy ss mt) = (entry_in_tree k v aa \ (k = yy \ v = ss) \ False \ xx \ k \ entry_in_tree k v mt)" by (simp add: balance_right_in_tree) thus ?case proof (cases "xx = k") case True - from 5 True have "tree_less yy aa \ yy < k" by simp - hence "tree_less k aa" by (blast dest: tree_less_trans) - with 3 5 True show ?thesis by (auto simp: tree_less_nit) + from 5 True have "aa |\ yy \ yy < k" by simp + hence "aa |\ k" by (blast dest: rbt_less_trans) + with 3 5 True show ?thesis by (auto simp: rbt_less_nit) qed auto next case ("6_1" xx aa yy ss) show ?case proof (cases "xx = k") case True - with "6_1" have "tree_less yy aa \ k > yy" by simp - hence "tree_less k aa" by (blast dest: tree_less_trans) - with "6_1" `xx = k` show ?thesis by (auto simp: tree_less_nit) + with "6_1" have "aa |\ yy \ k > yy" by simp + hence "aa |\ k" by (blast dest: rbt_less_trans) + with "6_1" `xx = k` show ?thesis by (auto simp: rbt_less_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 \ tree_less yy aa" by simp - hence "tree_less k aa" by (blast dest: tree_less_trans) - with True "6_2" show ?thesis by (auto simp: tree_less_nit) + with "6_2" have "k > yy \ aa |\ yy" by simp + hence "aa |\ k" by (blast dest: rbt_less_trans) + with True "6_2" show ?thesis by (auto simp: rbt_less_nit) qed auto qed simp +definition (in ord) rbt_delete where + "rbt_delete k t = paint B (rbt_del k t)" -definition delete where - delete_def: "delete k t = paint B (del k t)" - -theorem delete_is_rbt [simp]: assumes "is_rbt t" shows "is_rbt (delete k t)" +theorem rbt_delete_is_rbt [simp]: assumes "is_rbt t" shows "is_rbt (rbt_delete k t)" proof - from assms have "inv2 t" and "inv1 t" unfolding is_rbt_def by auto - hence "inv2 (del k t) \ (color_of t = R \ bheight (del k t) = bheight t \ inv1 (del k t) \ color_of t = B \ bheight (del k t) = bheight t - 1 \ inv1l (del k t))" by (rule del_inv1_inv2) - hence "inv2 (del k t) \ inv1l (del k t)" by (cases "color_of t") auto + hence "inv2 (rbt_del k t) \ (color_of t = R \ bheight (rbt_del k t) = bheight t \ inv1 (rbt_del k t) \ color_of t = B \ bheight (rbt_del k t) = bheight t - 1 \ inv1l (rbt_del k t))" by (rule rbt_del_inv1_inv2) + hence "inv2 (rbt_del k t) \ inv1l (rbt_del k t)" by (cases "color_of t") auto with assms show ?thesis - unfolding is_rbt_def delete_def - by (auto intro: paint_sorted del_sorted) + unfolding is_rbt_def rbt_delete_def + by (auto intro: paint_rbt_sorted rbt_del_rbt_sorted) qed -lemma delete_in_tree: +lemma rbt_delete_in_tree: assumes "is_rbt t" - shows "entry_in_tree k v (delete x t) = (x \ k \ entry_in_tree k v t)" - using assms unfolding is_rbt_def delete_def - by (auto simp: del_in_tree) + shows "entry_in_tree k v (rbt_delete x t) = (x \ k \ entry_in_tree k v t)" + using assms unfolding is_rbt_def rbt_delete_def + by (auto simp: rbt_del_in_tree) -lemma lookup_delete: +lemma rbt_lookup_rbt_delete: assumes is_rbt: "is_rbt t" - shows "lookup (delete k t) = (lookup t)|`(-{k})" + shows "rbt_lookup (rbt_delete k t) = (rbt_lookup t)|`(-{k})" proof fix x - show "lookup (delete k t) x = (lookup t |` (-{k})) x" + show "rbt_lookup (rbt_delete k t) x = (rbt_lookup t |` (-{k})) x" proof (cases "x = k") assume "x = k" with is_rbt show ?thesis - by (cases "lookup (delete k t) k") (auto simp: lookup_in_tree delete_in_tree) + by (cases "rbt_lookup (rbt_delete k t) k") (auto simp: rbt_lookup_in_tree rbt_delete_in_tree) next assume "x \ k" thus ?thesis - by auto (metis is_rbt delete_is_rbt delete_in_tree is_rbt_sorted lookup_from_in_tree) + by auto (metis is_rbt rbt_delete_is_rbt rbt_delete_in_tree is_rbt_rbt_sorted rbt_lookup_from_in_tree) qed qed +end subsection {* Union *} -primrec - union_with_key :: "('a\linorder \ 'b \ 'b \ 'b) \ ('a,'b) rbt \ ('a,'b) rbt \ ('a,'b) rbt" +context ord begin + +primrec rbt_union_with_key :: "('a \ 'b \ 'b \ 'b) \ ('a,'b) rbt \ ('a,'b) rbt \ ('a,'b) rbt" where - "union_with_key f t Empty = t" -| "union_with_key f t (Branch c lt k v rt) = union_with_key f (union_with_key f (insert_with_key f k v t) lt) rt" + "rbt_union_with_key f t Empty = t" +| "rbt_union_with_key f t (Branch c lt k v rt) = rbt_union_with_key f (rbt_union_with_key f (rbt_insert_with_key f k v t) lt) rt" -lemma unionwk_sorted: "sorted lt \ sorted (union_with_key f lt rt)" - by (induct rt arbitrary: lt) (auto simp: insertwk_sorted) -theorem unionwk_is_rbt[simp]: "is_rbt lt \ is_rbt (union_with_key f lt rt)" - by (induct rt arbitrary: lt) (simp add: insertwk_is_rbt)+ +definition rbt_union_with where + "rbt_union_with f = rbt_union_with_key (\_. f)" + +definition rbt_union where + "rbt_union = rbt_union_with_key (%_ _ rv. rv)" + +end -definition - union_with where - "union_with f = union_with_key (\_. f)" +context linorder begin -theorem unionw_is_rbt: "is_rbt lt \ is_rbt (union_with f lt rt)" unfolding union_with_def by simp +lemma rbt_unionwk_rbt_sorted: "rbt_sorted lt \ rbt_sorted (rbt_union_with_key f lt rt)" + by (induct rt arbitrary: lt) (auto simp: rbt_insertwk_rbt_sorted) +theorem rbt_unionwk_is_rbt[simp]: "is_rbt lt \ is_rbt (rbt_union_with_key f lt rt)" + by (induct rt arbitrary: lt) (simp add: rbt_insertwk_is_rbt)+ -definition union where - "union = union_with_key (%_ _ rv. rv)" +theorem rbt_unionw_is_rbt: "is_rbt lt \ is_rbt (rbt_union_with f lt rt)" unfolding rbt_union_with_def by simp + +theorem rbt_union_is_rbt: "is_rbt lt \ is_rbt (rbt_union lt rt)" unfolding rbt_union_def by simp -theorem union_is_rbt: "is_rbt lt \ is_rbt (union lt rt)" unfolding union_def by simp - -lemma union_Branch[simp]: - "union t (Branch c lt k v rt) = union (union (insert k v t) lt) rt" - unfolding union_def insert_def +lemma (in ord) rbt_union_Branch[simp]: + "rbt_union t (Branch c lt k v rt) = rbt_union (rbt_union (rbt_insert k v t) lt) rt" + unfolding rbt_union_def rbt_insert_def by simp -lemma lookup_union: - assumes "is_rbt s" "sorted t" - shows "lookup (union s t) = lookup s ++ lookup t" +lemma rbt_lookup_rbt_union: + assumes "is_rbt s" "rbt_sorted t" + shows "rbt_lookup (rbt_union s t) = rbt_lookup s ++ rbt_lookup t" using assms proof (induct t arbitrary: s) - case Empty thus ?case by (auto simp: union_def) + case Empty thus ?case by (auto simp: rbt_union_def) next case (Branch c l k v r s) - then have "sorted r" "sorted l" "l |\ k" "k \| r" by auto + then have "rbt_sorted r" "rbt_sorted l" "l |\ k" "k \| r" by auto - have meq: "lookup s(k \ v) ++ lookup l ++ lookup r = - lookup s ++ - (\a. if a < k then lookup l a - else if k < a then lookup r a else Some v)" (is "?m1 = ?m2") + have meq: "rbt_lookup s(k \ v) ++ rbt_lookup l ++ rbt_lookup r = + rbt_lookup s ++ + (\a. if a < k then rbt_lookup l a + else if k < a then rbt_lookup r a else Some v)" (is "?m1 = ?m2") proof (rule ext) fix a @@ -967,7 +1044,7 @@ thus "?m1 a = ?m2 a" proof (elim disjE) assume "k < a" - with `l |\ k` have "l |\ a" by (rule tree_less_trans) + with `l |\ k` have "l |\ a" by (rule rbt_less_trans) with `k < a` show ?thesis by (auto simp: map_add_def split: option.splits) next @@ -976,52 +1053,57 @@ show ?thesis by (auto simp: map_add_def) next assume "a < k" - from this `k \| r` have "a \| r" by (rule tree_greater_trans) + from this `k \| r` have "a \| r" by (rule rbt_greater_trans) with `a < k` show ?thesis by (auto simp: map_add_def split: option.splits) qed qed - from Branch have is_rbt: "is_rbt (RBT_Impl.union (RBT_Impl.insert k v s) l)" - by (auto intro: union_is_rbt insert_is_rbt) + from Branch have is_rbt: "is_rbt (RBT_Impl.rbt_union (RBT_Impl.rbt_insert k v s) l)" + by (auto intro: rbt_union_is_rbt rbt_insert_is_rbt) with Branch have IHs: - "lookup (union (union (insert k v s) l) r) = lookup (union (insert k v s) l) ++ lookup r" - "lookup (union (insert k v s) l) = lookup (insert k v s) ++ lookup l" + "rbt_lookup (rbt_union (rbt_union (rbt_insert k v s) l) r) = rbt_lookup (rbt_union (rbt_insert k v s) l) ++ rbt_lookup r" + "rbt_lookup (rbt_union (rbt_insert k v s) l) = rbt_lookup (rbt_insert k v s) ++ rbt_lookup l" by auto with meq show ?case - by (auto simp: lookup_insert[OF Branch(3)]) + by (auto simp: rbt_lookup_rbt_insert[OF Branch(3)]) qed +end subsection {* Modifying existing entries *} +context ord begin + primrec - map_entry :: "'a\linorder \ ('b \ 'b) \ ('a, 'b) rbt \ ('a, 'b) rbt" + rbt_map_entry :: "'a \ ('b \ 'b) \ ('a, 'b) rbt \ ('a, 'b) rbt" where - "map_entry k f Empty = Empty" -| "map_entry k f (Branch c lt x v rt) = - (if k < x then Branch c (map_entry k f lt) x v rt - else if k > x then (Branch c lt x v (map_entry k f rt)) + "rbt_map_entry k f Empty = Empty" +| "rbt_map_entry k f (Branch c lt x v rt) = + (if k < x then Branch c (rbt_map_entry k f lt) x v rt + else if k > x then (Branch c lt x v (rbt_map_entry k f rt)) else Branch c lt x (f v) rt)" -lemma map_entry_color_of: "color_of (map_entry k f t) = color_of t" by (induct t) simp+ -lemma map_entry_inv1: "inv1 (map_entry k f t) = inv1 t" by (induct t) (simp add: map_entry_color_of)+ -lemma map_entry_inv2: "inv2 (map_entry k f t) = inv2 t" "bheight (map_entry k f t) = bheight t" by (induct t) simp+ -lemma map_entry_tree_greater: "tree_greater a (map_entry k f t) = tree_greater a t" by (induct t) simp+ -lemma map_entry_tree_less: "tree_less a (map_entry k f t) = tree_less a t" by (induct t) simp+ -lemma map_entry_sorted: "sorted (map_entry k f t) = sorted t" - by (induct t) (simp_all add: map_entry_tree_less map_entry_tree_greater) + +lemma rbt_map_entry_color_of: "color_of (rbt_map_entry k f t) = color_of t" by (induct t) simp+ +lemma rbt_map_entry_inv1: "inv1 (rbt_map_entry k f t) = inv1 t" by (induct t) (simp add: rbt_map_entry_color_of)+ +lemma rbt_map_entry_inv2: "inv2 (rbt_map_entry k f t) = inv2 t" "bheight (rbt_map_entry k f t) = bheight t" by (induct t) simp+ +lemma rbt_map_entry_rbt_greater: "rbt_greater a (rbt_map_entry k f t) = rbt_greater a t" by (induct t) simp+ +lemma rbt_map_entry_rbt_less: "rbt_less a (rbt_map_entry k f t) = rbt_less a t" by (induct t) simp+ +lemma rbt_map_entry_rbt_sorted: "rbt_sorted (rbt_map_entry k f t) = rbt_sorted t" + by (induct t) (simp_all add: rbt_map_entry_rbt_less rbt_map_entry_rbt_greater) -theorem map_entry_is_rbt [simp]: "is_rbt (map_entry k f t) = is_rbt t" -unfolding is_rbt_def by (simp add: map_entry_inv2 map_entry_color_of map_entry_sorted map_entry_inv1 ) +theorem rbt_map_entry_is_rbt [simp]: "is_rbt (rbt_map_entry k f t) = is_rbt t" +unfolding is_rbt_def by (simp add: rbt_map_entry_inv2 rbt_map_entry_color_of rbt_map_entry_rbt_sorted rbt_map_entry_inv1 ) -theorem lookup_map_entry: - "lookup (map_entry k f t) = (lookup t)(k := Option.map f (lookup t k))" +end + +theorem (in linorder) rbt_lookup_rbt_map_entry: + "rbt_lookup (rbt_map_entry k f t) = (rbt_lookup t)(k := Option.map f (rbt_lookup t k))" by (induct t) (auto split: option.splits simp add: fun_eq_iff) - subsection {* Mapping all entries *} primrec @@ -1033,18 +1115,28 @@ lemma map_entries [simp]: "entries (map f t) = List.map (\(k, v). (k, f k v)) (entries t)" by (induct t) auto lemma map_keys [simp]: "keys (map f t) = keys t" by (simp add: keys_def split_def) -lemma map_tree_greater: "tree_greater k (map f t) = tree_greater k t" by (induct t) simp+ -lemma map_tree_less: "tree_less k (map f t) = tree_less k t" by (induct t) simp+ -lemma map_sorted: "sorted (map f t) = sorted t" by (induct t) (simp add: map_tree_less map_tree_greater)+ lemma map_color_of: "color_of (map f t) = color_of t" by (induct t) simp+ lemma map_inv1: "inv1 (map f t) = inv1 t" by (induct t) (simp add: map_color_of)+ lemma map_inv2: "inv2 (map f t) = inv2 t" "bheight (map f t) = bheight t" by (induct t) simp+ + +context ord begin + +lemma map_rbt_greater: "rbt_greater k (map f t) = rbt_greater k t" by (induct t) simp+ +lemma map_rbt_less: "rbt_less k (map f t) = rbt_less k t" by (induct t) simp+ +lemma map_rbt_sorted: "rbt_sorted (map f t) = rbt_sorted t" by (induct t) (simp add: map_rbt_less map_rbt_greater)+ theorem map_is_rbt [simp]: "is_rbt (map f t) = is_rbt t" -unfolding is_rbt_def by (simp add: map_inv1 map_inv2 map_sorted map_color_of) +unfolding is_rbt_def by (simp add: map_inv1 map_inv2 map_rbt_sorted map_color_of) -theorem lookup_map: "lookup (map f t) x = Option.map (f x) (lookup t x)" - by (induct t) auto +end +theorem (in linorder) rbt_lookup_map: "rbt_lookup (map f t) x = Option.map (f x) (rbt_lookup t x)" + apply(induct t) + apply auto + apply(subgoal_tac "x = a") + apply auto + done + (* FIXME: simproc "antisym less" does not work for linorder context, only for linorder type class + by (induct t) auto *) subsection {* Folding over entries *} @@ -1059,26 +1151,73 @@ subsection {* Bulkloading a tree *} -definition bulkload :: "('a \ 'b) list \ ('a\linorder, 'b) rbt" where - "bulkload xs = foldr (\(k, v). insert k v) xs Empty" +definition (in ord) rbt_bulkload :: "('a \ 'b) list \ ('a, 'b) rbt" where + "rbt_bulkload xs = foldr (\(k, v). rbt_insert k v) xs Empty" + +context linorder begin -lemma bulkload_is_rbt [simp, intro]: - "is_rbt (bulkload xs)" - unfolding bulkload_def by (induct xs) auto +lemma rbt_bulkload_is_rbt [simp, intro]: + "is_rbt (rbt_bulkload xs)" + unfolding rbt_bulkload_def by (induct xs) auto -lemma lookup_bulkload: - "lookup (bulkload xs) = map_of xs" +lemma rbt_lookup_rbt_bulkload: + "rbt_lookup (rbt_bulkload xs) = map_of xs" proof - obtain ys where "ys = rev xs" by simp have "\t. is_rbt t \ - lookup (List.fold (prod_case insert) ys t) = lookup t ++ map_of (rev ys)" - by (induct ys) (simp_all add: bulkload_def lookup_insert prod_case_beta) + rbt_lookup (List.fold (prod_case rbt_insert) ys t) = rbt_lookup t ++ map_of (rev ys)" + by (induct ys) (simp_all add: rbt_bulkload_def rbt_lookup_rbt_insert prod_case_beta) from this Empty_is_rbt have - "lookup (List.fold (prod_case insert) (rev xs) Empty) = lookup Empty ++ map_of xs" + "rbt_lookup (List.fold (prod_case rbt_insert) (rev xs) Empty) = rbt_lookup Empty ++ map_of xs" by (simp add: `ys = rev xs`) - then show ?thesis by (simp add: bulkload_def lookup_Empty foldr_conv_fold) + then show ?thesis by (simp add: rbt_bulkload_def rbt_lookup_Empty foldr_conv_fold) qed -hide_const (open) R B Empty insert delete entries keys bulkload lookup map_entry map fold union sorted +end + +lemmas [code] = + ord.rbt_less_prop + ord.rbt_greater_prop + ord.rbt_sorted.simps + ord.rbt_lookup.simps + ord.is_rbt_def + ord.rbt_ins.simps + ord.rbt_insert_with_key_def + ord.rbt_insertw_def + ord.rbt_insert_def + ord.rbt_del_from_left.simps + ord.rbt_del_from_right.simps + ord.rbt_del.simps + ord.rbt_delete_def + ord.rbt_union_with_key.simps + ord.rbt_union_with_def + ord.rbt_union_def + ord.rbt_map_entry.simps + ord.rbt_bulkload_def + +text {* Restore original type constraints for constants *} +setup {* + fold Sign.add_const_constraint + [(@{const_name rbt_less}, SOME @{typ "('a :: order) \ ('a, 'b) rbt \ bool"}), + (@{const_name rbt_greater}, SOME @{typ "('a :: order) \ ('a, 'b) rbt \ bool"}), + (@{const_name rbt_sorted}, SOME @{typ "('a :: linorder, 'b) rbt \ bool"}), + (@{const_name rbt_lookup}, SOME @{typ "('a :: linorder, 'b) rbt \ 'a \ 'b"}), + (@{const_name is_rbt}, SOME @{typ "('a :: linorder, 'b) rbt \ bool"}), + (@{const_name rbt_ins}, SOME @{typ "('a\linorder \ 'b \ 'b \ 'b) \ 'a \ 'b \ ('a,'b) rbt \ ('a,'b) rbt"}), + (@{const_name rbt_insert_with_key}, SOME @{typ "('a\linorder \ 'b \ 'b \ 'b) \ 'a \ 'b \ ('a,'b) rbt \ ('a,'b) rbt"}), + (@{const_name rbt_insert_with}, SOME @{typ "('b \ 'b \ 'b) \ ('a :: linorder) \ 'b \ ('a,'b) rbt \ ('a,'b) rbt"}), + (@{const_name rbt_insert}, SOME @{typ "('a :: linorder) \ 'b \ ('a,'b) rbt \ ('a,'b) rbt"}), + (@{const_name rbt_del_from_left}, SOME @{typ "('a\linorder) \ ('a,'b) rbt \ 'a \ 'b \ ('a,'b) rbt \ ('a,'b) rbt"}), + (@{const_name rbt_del_from_right}, SOME @{typ "('a\linorder) \ ('a,'b) rbt \ 'a \ 'b \ ('a,'b) rbt \ ('a,'b) rbt"}), + (@{const_name rbt_del}, SOME @{typ "('a\linorder) \ ('a,'b) rbt \ ('a,'b) rbt"}), + (@{const_name rbt_delete}, SOME @{typ "('a\linorder) \ ('a,'b) rbt \ ('a,'b) rbt"}), + (@{const_name rbt_union_with_key}, SOME @{typ "('a\linorder \ 'b \ 'b \ 'b) \ ('a,'b) rbt \ ('a,'b) rbt \ ('a,'b) rbt"}), + (@{const_name rbt_union_with}, SOME @{typ "('b \ 'b \ 'b) \ ('a\linorder,'b) rbt \ ('a,'b) rbt \ ('a,'b) rbt"}), + (@{const_name rbt_union}, SOME @{typ "('a\linorder,'b) rbt \ ('a,'b) rbt \ ('a,'b) rbt"}), + (@{const_name rbt_map_entry}, SOME @{typ "'a\linorder \ ('b \ 'b) \ ('a,'b) rbt \ ('a,'b) rbt"}), + (@{const_name rbt_bulkload}, SOME @{typ "('a \ 'b) list \ ('a\linorder,'b) rbt"})] +*} + +hide_const (open) R B Empty entries keys map fold end diff -r 11a0aa6cc677 -r 2ada2be850cb src/HOL/Library/RBT_Mapping.thy --- a/src/HOL/Library/RBT_Mapping.thy Thu Apr 12 13:47:21 2012 +0200 +++ b/src/HOL/Library/RBT_Mapping.thy Fri Apr 13 11:45:30 2012 +0200 @@ -40,7 +40,7 @@ lemma keys_Mapping [code]: "Mapping.keys (Mapping t) = set (keys t)" - by (simp add: RBT.keys_def Mapping_def Mapping.keys_def lookup_def lookup_keys) + by (simp add: RBT.keys_def Mapping_def Mapping.keys_def lookup_def rbt_lookup_keys) lemma ordered_keys_Mapping [code]: "Mapping.ordered_keys (Mapping t) = keys t" @@ -144,22 +144,22 @@ @{thm Empty_is_rbt}\hfill(@{text "Empty_is_rbt"}) \noindent - @{thm insert_is_rbt}\hfill(@{text "insert_is_rbt"}) + @{thm rbt_insert_is_rbt}\hfill(@{text "rbt_insert_is_rbt"}) \noindent - @{thm delete_is_rbt}\hfill(@{text "delete_is_rbt"}) + @{thm rbt_delete_is_rbt}\hfill(@{text "delete_is_rbt"}) \noindent - @{thm bulkload_is_rbt}\hfill(@{text "bulkload_is_rbt"}) + @{thm rbt_bulkload_is_rbt}\hfill(@{text "bulkload_is_rbt"}) \noindent - @{thm map_entry_is_rbt}\hfill(@{text "map_entry_is_rbt"}) + @{thm rbt_map_entry_is_rbt}\hfill(@{text "map_entry_is_rbt"}) \noindent @{thm map_is_rbt}\hfill(@{text "map_is_rbt"}) \noindent - @{thm union_is_rbt}\hfill(@{text "union_is_rbt"}) + @{thm rbt_union_is_rbt}\hfill(@{text "union_is_rbt"}) *}