Commit 7445e476 authored by Niels Mündler's avatar Niels Mündler
Browse files

Add imperative deletion operation and OCaml code export to BTree entry

parent 1edcb594d89c
...@@ -10349,7 +10349,7 @@ abstract = ...@@ -10349,7 +10349,7 @@ abstract =
In this work, we use the interactive theorem prover Isabelle/HOL to In this work, we use the interactive theorem prover Isabelle/HOL to
verify an imperative implementation of the classical B-tree data verify an imperative implementation of the classical B-tree data
structure invented by Bayer and McCreight [ACM 1970]. The structure invented by Bayer and McCreight [ACM 1970]. The
implementation supports set membership and insertion queries with implementation supports set membership, insertion and deletion queries with
efficient binary search for intra-node navigation. This is efficient binary search for intra-node navigation. This is
accomplished by first specifying the structure abstractly in the accomplished by first specifying the structure abstractly in the
functional modeling language HOL and proving functional correctness. functional modeling language HOL and proving functional correctness.
...@@ -10358,12 +10358,18 @@ abstract = ...@@ -10358,12 +10358,18 @@ abstract =
separation logic utilities from the <a separation logic utilities from the <a
href="https://www.isa-afp.org/entries/Refine_Imperative_HOL.html"> href="https://www.isa-afp.org/entries/Refine_Imperative_HOL.html">
Isabelle Refinement Framework </a> . The code can be exported to Isabelle Refinement Framework </a> . The code can be exported to
the programming languages SML and Scala. We examine the runtime of all the programming languages SML, OCaml and Scala. We examine the runtime of all
operations indirectly by reproducing results of the logarithmic operations indirectly by reproducing results of the logarithmic
relationship between height and the number of nodes. The results are relationship between height and the number of nodes. The results are
discussed in greater detail in the corresponding <a discussed in greater detail in the corresponding <a
href="https://mediatum.ub.tum.de/1596550">Bachelor's href="https://mediatum.ub.tum.de/1596550">Bachelor's
Thesis</a>. Thesis</a>.
extra-history =
Change history:
[2021-05-02]:
Add implementation and proof of correctness of imperative deletion operations.
Further add the option to export code to OCaml.
<br>
   
[Sunflowers] [Sunflowers]
title = The Sunflower Lemma of Erdős and Rado title = The Sunflower Lemma of Erdős and Rado
......
...@@ -2,6 +2,26 @@ theory Array_SBlit ...@@ -2,6 +2,26 @@ theory Array_SBlit
imports "Separation_Logic_Imperative_HOL.Array_Blit" imports "Separation_Logic_Imperative_HOL.Array_Blit"
begin begin
(* Resolves TODO by Peter Lammich *)
(* OCaml handles the case of len=0 correctly (i.e.
as specified by the Hoare Triple in Array_Blit
not generating an exception if si+len \<le> array length and such) *)
code_printing code_module "array_blit" \<rightharpoonup> (OCaml)
\<open>
let array_blit src si dst di len = (
if src=dst then
raise (Invalid_argument "array_blit: Same arrays")
else
Array.blit src (Z.to_int si) dst (Z.to_int di) (Z.to_int len)
)
\<close>
code_printing constant blit' \<rightharpoonup>
(OCaml) "(fun () -> /array'_blit _ _ _ _ _)"
export_code blit checking OCaml
section "Same array Blit" section "Same array Blit"
text "The standard framework already provides a function to copy array text "The standard framework already provides a function to copy array
...@@ -117,7 +137,6 @@ next ...@@ -117,7 +137,6 @@ next
have[simp]: "take len (drop si (lsrc[di + len := lsrc ! (si + len)])) have[simp]: "take len (drop si (lsrc[di + len := lsrc ! (si + len)]))
= take len (drop si lsrc)" = take len (drop si lsrc)"
sledgehammer
by (metis Suc.prems(2) ab_semigroup_add_class.add.commute add_le_cancel_right take_drop take_update_cancel) by (metis Suc.prems(2) ab_semigroup_add_class.add.commute add_le_cancel_right take_drop take_update_cancel)
have [simp]: "drop (di + len) (lsrc[di + len := lsrc ! (si + len)]) have [simp]: "drop (di + len) (lsrc[di + len := lsrc ! (si + len)])
= lsrc ! (si+len) # drop (Suc di + len) lsrc" = lsrc ! (si+len) # drop (Suc di + len) lsrc"
...@@ -173,8 +192,10 @@ thm safe_sblit_rule ...@@ -173,8 +192,10 @@ thm safe_sblit_rule
subsection "Code Generator Setup" subsection "Code Generator Setup"
text "Note that the requirement for correctness text "Note that the requirement for correctness
is even weaker here than in SML. is even weaker here than in SML/OCaml.
We therefore manually handle the case where length is 0 (in which case nothing happens at all)." In particular, if the length of the slice to copy is equal to 0,
we will never throw an exception.
We therefore manually handle this case, where nothing happens at all."
code_printing code_module "array_sblit" \<rightharpoonup> (SML) code_printing code_module "array_sblit" \<rightharpoonup> (SML)
\<open> \<open>
...@@ -188,6 +209,15 @@ code_printing code_module "array_sblit" \<rightharpoonup> (SML) ...@@ -188,6 +209,15 @@ code_printing code_module "array_sblit" \<rightharpoonup> (SML)
) )
\<close> \<close>
code_printing code_module "array_sblit" \<rightharpoonup> (OCaml)
\<open>
let array_sblit src si di len = (
if len > Z.zero then
(Array.blit src (Z.to_int si) src (Z.to_int di) (Z.to_int len))
else ()
)
\<close>
definition safe_sblit' where definition safe_sblit' where
[code del]: "safe_sblit' src si di len [code del]: "safe_sblit' src si di len
= safe_sblit src (nat_of_integer si) (nat_of_integer di) = safe_sblit src (nat_of_integer si) (nat_of_integer di)
...@@ -198,7 +228,7 @@ lemma [code]: ...@@ -198,7 +228,7 @@ lemma [code]:
= safe_sblit' src (integer_of_nat si) (integer_of_nat di) = safe_sblit' src (integer_of_nat si) (integer_of_nat di)
(integer_of_nat len)" by (simp add: safe_sblit'_def) (integer_of_nat len)" by (simp add: safe_sblit'_def)
(* TODO: Export to other languages: OCaml, Haskell *) (* TODO: Export to other languages: Haskell *)
code_printing constant safe_sblit' \<rightharpoonup> code_printing constant safe_sblit' \<rightharpoonup>
(SML) "(fn/ ()/ => /array'_sblit _ _ _ _)" (SML) "(fn/ ()/ => /array'_sblit _ _ _ _)"
and (Scala) "{ ('_: Unit)/=>/ and (Scala) "{ ('_: Unit)/=>/
...@@ -211,7 +241,13 @@ code_printing constant safe_sblit' \<rightharpoonup> ...@@ -211,7 +241,13 @@ code_printing constant safe_sblit' \<rightharpoonup>
safescopy(_.array,_.toInt,_.toInt,_.toInt) safescopy(_.array,_.toInt,_.toInt,_.toInt)
}" }"
export_code safe_sblit checking SML Scala code_printing constant safe_sblit' \<rightharpoonup>
(OCaml) "(fun () -> /array'_sblit _ _ _ _)"
export_code safe_sblit checking SML Scala OCaml
subsection "Derived operations" subsection "Derived operations"
......
This diff is collapsed.
...@@ -403,17 +403,22 @@ global_interpretation btree_imp_binary_split: imp_split_smeq bin_split ...@@ -403,17 +403,22 @@ global_interpretation btree_imp_binary_split: imp_split_smeq bin_split
defines btree_isin = btree_imp_binary_split.isin defines btree_isin = btree_imp_binary_split.isin
and btree_ins = btree_imp_binary_split.ins and btree_ins = btree_imp_binary_split.ins
and btree_insert = btree_imp_binary_split.insert and btree_insert = btree_imp_binary_split.insert
and btree_del = btree_imp_binary_split.del
and btree_split_max = btree_imp_binary_split.split_max
and btree_delete = btree_imp_binary_split.delete
and btree_empty = btree_imp_binary_split.empty and btree_empty = btree_imp_binary_split.empty
apply unfold_locales apply unfold_locales
apply(sep_auto heap: bin_split_rule) apply(sep_auto heap: bin_split_rule)
done done
thm btree_imp_binary_split.ins.simps declare btree_imp_binary_split.ins.simps[code]
declare btree_imp_binary_split.ins.simps[code] btree_imp_binary_split.isin.simps[code] declare btree_imp_binary_split.isin.simps[code]
declare btree_imp_binary_split.del.simps[code] btree_imp_binary_split.split_max.simps[code]
export_code btree_empty btree_isin btree_insert checking SML Scala export_code btree_empty btree_isin btree_insert btree_delete checking OCaml SML Scala
export_code btree_empty btree_isin btree_insert in SML module_name BTreeInsert export_code btree_empty btree_isin btree_insert btree_delete in OCaml module_name BTree
export_code btree_empty btree_isin btree_insert in Scala module_name BTreeInsert export_code btree_empty btree_isin btree_insert btree_delete in SML module_name BTree
export_code btree_empty btree_isin btree_insert btree_delete in Scala module_name BTree
end end
theory BTree_Map
imports BTree_Set "HOL-Data_Structures.Map_Specs"
begin
term "(1,2)"
term int
fun eq_kv where
"eq_kv (k1, v1) (k2,v2) = (k1 = k2)"
datatype ('a, 'b) ukv = KV 'a 'b
quotient_type ('a,'b) kv = "('a, 'b) prod" / eq_kv
apply(rule equivpI)
apply (auto simp add: reflp_def symp_def transp_def)
done
type_notation (ASCII)
kv (infixr "\<mapsto>" 20)
instantiation kv :: (linorder, type) linorder
begin
fun less_eq_ukv::"'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool"
where "less_eq_ukv (k1, v1) (k2, v2) = (k1 \<le> k2)"
lift_definition less_eq_kv :: "'a \<mapsto> 'b \<Rightarrow> 'a \<mapsto> 'b \<Rightarrow> bool" is less_eq_ukv
by auto
definition less_kv:: "'a \<mapsto> 'b \<Rightarrow> 'a \<mapsto> 'b \<Rightarrow> bool"
where "less_kv a b = (a \<le> b \<and> \<not>b \<le> a)"
instance
proof(standard, goal_cases)
case (1 x y)
then show ?case by (simp add: less_kv_def)
next
case (2 x)
then show ?case
by (transfer; clarsimp)
next
case (3 x y z)
then show ?case
by (transfer; auto)
next
case (4 x y)
then show ?case
by (transfer; auto)
next
case (5 x y)
then show ?case
by (transfer; auto)
qed
end
locale split_default = abs_split: BTree_Set.split split
for split::
"(('a \<mapsto> 'b) btree \<times> ('a::{linorder} \<mapsto> 'b::{default})) list \<Rightarrow> ('a \<mapsto> 'b)
\<Rightarrow> (('a \<mapsto> 'b) btree \<times> ('a \<mapsto> 'b)) list \<times> (('a \<mapsto> 'b) btree \<times> ('a \<mapsto> 'b)) list"
begin
lift_definition lift :: "'a \<Rightarrow> ('a \<mapsto> 'b)" is
"\<lambda>a. (a, default)" .
lift_definition val :: "('a \<mapsto> 'b) \<Rightarrow> 'b" is
"\<lambda>(a,b). b"
apply auto
sorry
fun find where
"find (Leaf) y = None" |
"find (Node ts t) y = (
case split ts y of (_,(sub,sep)#rs) \<Rightarrow> (
if y = sep then
Some sep
else
find sub y
)
| (_,[]) \<Rightarrow> find t y
)"
fun lookup :: "('a \<mapsto> 'b option) btree \<Rightarrow> 'a \<Rightarrow> 'a option"
where "lookup t x = (case find t (x,None) of Some (a,b) \<Rightarrow> Some b | None \<Rightarrow> None)"
interpretation btree_map: Map_by_Ordered
empty_btree
end
end
\ No newline at end of file
...@@ -106,18 +106,23 @@ fun node\<^sub>i:: "nat \<Rightarrow> ('a btree \<times> 'a) list \<Rightarrow> ...@@ -106,18 +106,23 @@ fun node\<^sub>i:: "nat \<Rightarrow> ('a btree \<times> 'a) list \<Rightarrow>
) )
)" )"
lemma nodei_ti_simp: "node\<^sub>i k ts t = T\<^sub>i x \<Longrightarrow> x = Node ts t"
apply (cases "length ts \<le> 2*k")
apply (auto split!: list.splits)
done
fun ins:: "nat \<Rightarrow> 'a \<Rightarrow> 'a btree \<Rightarrow> 'a up\<^sub>i" where fun ins:: "nat \<Rightarrow> 'a \<Rightarrow> 'a btree \<Rightarrow> 'a up\<^sub>i" where
"ins k x Leaf = (Up\<^sub>i Leaf x Leaf)" | "ins k x Leaf = (Up\<^sub>i Leaf x Leaf)" |
"ins k x (Node ts t) = ( "ins k x (Node ts t) = (
case split ts x of case split ts x of
(ls,(sub,sep)#rs) \<Rightarrow> (ls,(sub,sep)#rs) \<Rightarrow>
(if sep = x then (if sep = x then
T\<^sub>i (Node ts t) T\<^sub>i (Node ts t)
else else
(case ins k x sub of (case ins k x sub of
Up\<^sub>i l a r \<Rightarrow> Up\<^sub>i l a r \<Rightarrow>
node\<^sub>i k (ls @ (l,a)#(r,sep)#rs) t | node\<^sub>i k (ls @ (l,a)#(r,sep)#rs) t |
T\<^sub>i a \<Rightarrow> T\<^sub>i a \<Rightarrow>
T\<^sub>i (Node (ls @ (a,sep) # rs) t))) | T\<^sub>i (Node (ls @ (a,sep) # rs) t))) |
(ls, []) \<Rightarrow> (ls, []) \<Rightarrow>
...@@ -140,7 +145,7 @@ fun insert::"nat \<Rightarrow> 'a \<Rightarrow> 'a btree \<Rightarrow> 'a btree" ...@@ -140,7 +145,7 @@ fun insert::"nat \<Rightarrow> 'a \<Rightarrow> 'a btree \<Rightarrow> 'a btree"
subsection "Deletion" subsection "Deletion"
text "The following deletion method is inspired by Bayer (70) and Fielding (??). text "The following deletion method is inspired by Bauer (70) and Fielding (??).
Rather than stealing only a single node from the neighbour, Rather than stealing only a single node from the neighbour,
the neighbour is fully merged with the potentially underflowing node. the neighbour is fully merged with the potentially underflowing node.
If the resulting node is still larger than allowed, the merged node is split If the resulting node is still larger than allowed, the merged node is split
...@@ -152,7 +157,7 @@ fun rebalance_middle_tree where ...@@ -152,7 +157,7 @@ fun rebalance_middle_tree where
Node (ls@(Leaf,sep)#rs) Leaf Node (ls@(Leaf,sep)#rs) Leaf
)" | )" |
"rebalance_middle_tree k ls (Node mts mt) sep rs (Node tts tt) = ( "rebalance_middle_tree k ls (Node mts mt) sep rs (Node tts tt) = (
if length mts \<ge> k \<and> length tts \<ge> k then if length mts \<ge> k \<and> length tts \<ge> k then
Node (ls@(Node mts mt,sep)#rs) (Node tts tt) Node (ls@(Node mts mt,sep)#rs) (Node tts tt)
else ( else (
case rs of [] \<Rightarrow> ( case rs of [] \<Rightarrow> (
...@@ -193,10 +198,10 @@ it resides in the same pair as the separating element to be removed." ...@@ -193,10 +198,10 @@ it resides in the same pair as the separating element to be removed."
fun split_max where fun split_max where
"split_max k (Node ts t) = (case t of Leaf \<Rightarrow> ( "split_max k (Node ts t) = (case t of Leaf \<Rightarrow> (
let (sub,sep) = last ts in let (sub,sep) = last ts in
(Node (butlast ts) sub, sep) (Node (butlast ts) sub, sep)
)| )|
_ \<Rightarrow> _ \<Rightarrow>
case split_max k t of (sub, sep) \<Rightarrow> case split_max k t of (sub, sep) \<Rightarrow>
(rebalance_last_tree k ts sub, sep) (rebalance_last_tree k ts sub, sep)
)" )"
...@@ -204,11 +209,11 @@ case split_max k t of (sub, sep) \<Rightarrow> ...@@ -204,11 +209,11 @@ case split_max k t of (sub, sep) \<Rightarrow>
fun del where fun del where
"del k x Leaf = Leaf" | "del k x Leaf = Leaf" |
"del k x (Node ts t) = ( "del k x (Node ts t) = (
case split ts x of case split ts x of
(ls,[]) \<Rightarrow> (ls,[]) \<Rightarrow>
rebalance_last_tree k ls (del k x t) rebalance_last_tree k ls (del k x t)
| (ls,(sub,sep)#rs) \<Rightarrow> ( | (ls,(sub,sep)#rs) \<Rightarrow> (
if sep \<noteq> x then if sep \<noteq> x then
rebalance_middle_tree k ls (del k x sub) sep rs t rebalance_middle_tree k ls (del k x sub) sep rs t
else if sub = Leaf then else if sub = Leaf then
Node (ls@rs) t Node (ls@rs) t
...@@ -252,7 +257,7 @@ fun nonempty_lasttreebal where ...@@ -252,7 +257,7 @@ fun nonempty_lasttreebal where
subsection "Proofs of functional correctness" subsection "Proofs of functional correctness"
lemma split_set: lemma split_set:
assumes "split ts z = (ls,(a,b)#rs)" assumes "split ts z = (ls,(a,b)#rs)"
shows "(a,b) \<in> set ts" shows "(a,b) \<in> set ts"
and "(x,y) \<in> set ls \<Longrightarrow> (x,y) \<in> set ts" and "(x,y) \<in> set ls \<Longrightarrow> (x,y) \<in> set ts"
...@@ -340,7 +345,7 @@ proof(induction t x rule: isin.induct) ...@@ -340,7 +345,7 @@ proof(induction t x rule: isin.induct)
case (2 ts t x) case (2 ts t x)
then obtain ls rs where list_split: "split ts x = (ls, rs)" then obtain ls rs where list_split: "split ts x = (ls, rs)"
by (meson surj_pair) by (meson surj_pair)
then have list_conc: "ts = ls @ rs" then have list_conc: "ts = ls @ rs"
using split_conc by auto using split_conc by auto
show ?case show ?case
proof (cases rs) proof (cases rs)
...@@ -414,9 +419,9 @@ proof (cases "length ts \<le> 2*k") ...@@ -414,9 +419,9 @@ proof (cases "length ts \<le> 2*k")
by (simp add: node\<^sub>i.simps) by (simp add: node\<^sub>i.simps)
next next
case False case False
then obtain ls sub sep rs where split_half_ts: then obtain ls sub sep rs where split_half_ts:
"take (length ts div 2) ts = ls" "take (length ts div 2) ts = ls"
"drop (length ts div 2) ts = (sub,sep)#rs" "drop (length ts div 2) ts = (sub,sep)#rs"
using split_half_not_empty[of ts] using split_half_not_empty[of ts]
by auto by auto
then have length_rs: "length rs = length ts - (length ts div 2) - 1" then have length_rs: "length rs = length ts - (length ts div 2) - 1"
...@@ -428,7 +433,7 @@ next ...@@ -428,7 +433,7 @@ next
by auto by auto
finally have "length rs \<le> 2*k" finally have "length rs \<le> 2*k"
by simp by simp
moreover have "length rs \<ge> k" moreover have "length rs \<ge> k"
using False length_rs by simp using False length_rs by simp
moreover have "set ((sub,sep)#rs) \<subseteq> set ts" moreover have "set ((sub,sep)#rs) \<subseteq> set ts"
by (metis split_half_ts(2) set_drop_subset) by (metis split_half_ts(2) set_drop_subset)
...@@ -460,8 +465,8 @@ proof (cases "length ts \<le> 2*k") ...@@ -460,8 +465,8 @@ proof (cases "length ts \<le> 2*k")
by (simp add: node\<^sub>i.simps) by (simp add: node\<^sub>i.simps)
next next
case False case False
then obtain sub sep rs where then obtain sub sep rs where
"drop (length ts div 2) ts = (sub,sep)#rs" "drop (length ts div 2) ts = (sub,sep)#rs"
using split_half_not_empty[of ts] using split_half_not_empty[of ts]
by auto by auto
then show ?thesis then show ?thesis
...@@ -483,7 +488,7 @@ lemma node\<^sub>i_order: ...@@ -483,7 +488,7 @@ lemma node\<^sub>i_order:
done done
(* explicit proof *) (* explicit proof *)
lemma ins_order: lemma ins_order:
"order k t \<Longrightarrow> order_up\<^sub>i k (ins k x t)" "order k t \<Longrightarrow> order_up\<^sub>i k (ins k x t)"
proof(induction k x t rule: ins.induct) proof(induction k x t rule: ins.induct)
case (2 k x ts t) case (2 k x ts t)
...@@ -525,7 +530,7 @@ qed simp ...@@ -525,7 +530,7 @@ qed simp
(* notice this is almost a duplicate of ins_order *) (* notice this is almost a duplicate of ins_order *)
lemma ins_root_order: lemma ins_root_order:
assumes "root_order k t" assumes "root_order k t"
shows "root_order_up\<^sub>i k (ins k x t)" shows "root_order_up\<^sub>i k (ins k x t)"
proof(cases t) proof(cases t)
...@@ -662,7 +667,7 @@ proof(induction k x t rule: ins.induct) ...@@ -662,7 +667,7 @@ proof(induction k x t rule: ins.induct)
using height_sub by auto using height_sub by auto
then have "height (Node (ls@(sub,sep)#rs) t) = height (Node (ls@(a,sep)#rs) t)" then have "height (Node (ls@(sub,sep)#rs) t) = height (Node (ls@(a,sep)#rs) t)"
by auto by auto
then show ?thesis then show ?thesis
using T\<^sub>i height_sub False Cons 2 split_list a_split split_append using T\<^sub>i height_sub False Cons 2 split_list a_split split_append
by (auto simp add: image_Un max.commute finite_set_ins_swap) by (auto simp add: image_Un max.commute finite_set_ins_swap)
next next
...@@ -692,17 +697,17 @@ proof(induction k x t rule: ins.induct) ...@@ -692,17 +697,17 @@ proof(induction k x t rule: ins.induct)
show ?case show ?case
proof (cases rs) proof (cases rs)
case Nil case Nil
then show ?thesis then show ?thesis
proof (cases "ins k x t") proof (cases "ins k x t")
case (T\<^sub>i a) case (T\<^sub>i a)
then have "bal (Node ls a)" unfolding bal.simps then have "bal (Node ls a)" unfolding bal.simps
by (metis "2.IH"(1) "2.prems" append_Nil2 bal.simps(2) bal_up\<^sub>i.simps(1) height_up\<^sub>i.simps(1) ins_height local.Nil split_app split_res) by (metis "2.IH"(1) "2.prems" append_Nil2 bal.simps(2) bal_up\<^sub>i.simps(1) height_up\<^sub>i.simps(1) ins_height local.Nil split_app split_res)
then show ?thesis then show ?thesis
using Nil T\<^sub>i 2 split_res using Nil T\<^sub>i 2 split_res
by simp by simp
next next
case (Up\<^sub>i l a r) case (Up\<^sub>i l a r)
then have then have
"(\<forall>x\<in>set (subtrees (ls@[(l,a)])). bal x)" "(\<forall>x\<in>set (subtrees (ls@[(l,a)])). bal x)"
"(\<forall>x\<in>set (subtrees ls). height r = height x)" "(\<forall>x\<in>set (subtrees ls). height r = height x)"
using 2 Up\<^sub>i Nil split_res split_app using 2 Up\<^sub>i Nil split_res split_app
...@@ -845,7 +850,7 @@ lemma ins_list_contains_idem: "\<lbrakk>sorted_less xs; x \<in> set xs\<rbrakk> ...@@ -845,7 +850,7 @@ lemma ins_list_contains_idem: "\<lbrakk>sorted_less xs; x \<in> set xs\<rbrakk>
declare node\<^sub>i.simps [simp del] declare node\<^sub>i.simps [simp del]
declare node\<^sub>i_inorder [simp add] declare node\<^sub>i_inorder [simp add]
lemma ins_inorder: "sorted_less (inorder t) \<Longrightarrow> (inorder_up\<^sub>i (ins k x t)) = ins_list x (inorder t)" lemma ins_inorder: "sorted_less (inorder t) \<Longrightarrow> (inorder_up\<^sub>i (ins k x t)) = ins_list x (inorder t)"
proof(induction k x t rule: ins.induct) proof(induction k x t rule: ins.induct)
...@@ -1041,7 +1046,7 @@ next ...@@ -1041,7 +1046,7 @@ next
case (T\<^sub>i u) case (T\<^sub>i u)
then have "height u = max (height rsub) (height sub)" then have "height u = max (height rsub) (height sub)"
using height_max by simp using height_max by simp
then show ?thesis then show ?thesis
using T\<^sub>i False Cons r_node a_split sub_node t_node by auto using T\<^sub>i False Cons r_node a_split sub_node t_node by auto
next next
case (Up\<^sub>i l a r) case (Up\<^sub>i l a r)
...@@ -1119,7 +1124,7 @@ proof(induction k x t rule: del.induct) ...@@ -1119,7 +1124,7 @@ proof(induction k x t rule: del.induct)
by (metis append_Nil2 nonempty_lasttreebal.simps(2) order_bal_nonempty_lasttreebal) by (metis append_Nil2 nonempty_lasttreebal.simps(2) order_bal_nonempty_lasttreebal)
moreover have "Node ls t = Node ts t" using split_conc Nil list_split by auto moreover have "Node ls t = Node ts t" using split_conc Nil list_split by auto
ultimately show ?thesis ultimately show ?thesis
using rebalance_last_tree_height 2 list_split Nil split_conc using rebalance_last_tree_height 2 list_split Nil split_conc
by (auto simp add: max.assoc sup_nat_def max_def) by (auto simp add: max.assoc sup_nat_def max_def)
next next
case (Cons a rs) case (Cons a rs)
...@@ -1127,7 +1132,7 @@ proof(induction k x t rule: del.induct) ...@@ -1127,7 +1132,7 @@ proof(induction k x t rule: del.induct)
using "2.prems"(3) bal_sub_height list_split split_conc by blast using "2.prems"(3) bal_sub_height list_split split_conc by blast
from Cons obtain sub sep where a_split: "a = (sub,sep)" by (cases a) from Cons obtain sub sep where a_split: "a = (sub,sep)" by (cases a)
consider (sep_n_x) "sep \<noteq> x" | consider (sep_n_x) "sep \<noteq> x" |
(sep_x_Leaf) "sep = x \<and> sub = Leaf" | (sep_x_Leaf) "sep = x \<and> sub = Leaf" |
(sep_x_Node) "sep = x \<and> (\<exists>ts t. sub = Node ts t)" (sep_x_Node) "sep = x \<and> (\<exists>ts t. sub = Node ts t)"
using btree.exhaust by blast using btree.exhaust by blast
then show ?thesis then show ?thesis
...@@ -1182,7 +1187,7 @@ lemma rebalance_middle_tree_inorder: ...@@ -1182,7 +1187,7 @@ lemma rebalance_middle_tree_inorder:
and "case rs of (rsub,rsep) # list \<Rightarrow> height rsub = height t | [] \<Rightarrow> True" and "case rs of (rsub,rsep) # list \<Rightarrow> height rsub = height t | [] \<Rightarrow> True"
shows "inorder (rebalance_middle_tree k ls sub sep rs t) = inorder (Node (ls@(sub,sep)#rs) t)" shows "inorder (rebalance_middle_tree k ls sub sep rs t) = inorder (Node (ls@(sub,sep)#rs) t)"
apply(cases sub; cases t) apply(cases sub; cases t)
using assms using assms
apply (auto apply (auto
split!: btree.splits up\<^sub>i.splits list.splits split!: btree.splits up\<^sub>i.splits list.splits
simp del: node\<^sub>i.simps simp del: node\<^sub>i.simps
...@@ -1203,7 +1208,7 @@ lemma split_max_inorder: ...@@ -1203,7 +1208,7 @@ lemma split_max_inorder:
assumes "nonempty_lasttreebal t" assumes "nonempty_lasttreebal t"
and "t \<noteq> Leaf" and "t \<noteq> Leaf"
shows "inorder_pair (split_max k t) = inorder t" shows "inorder_pair (split_max k t) = inorder t"
using assms using assms
proof (induction k t rule: split_max.induct) proof (induction k t rule: split_max.induct)
case (1 k ts t) case (1 k ts t)
then show ?case then show ?case
...@@ -1214,7 +1219,7 @@ proof (induction k t rule: split_max.induct) ...@@ -1214,7 +1219,7 @@ proof (induction k t rule: split_max.induct)
moreover obtain sub sep where "last ts = (sub,sep)" moreover obtain sub sep where "last ts = (sub,sep)"
by fastforce by fastforce
ultimately show ?thesis ultimately show ?thesis
using Leaf using Leaf
apply (auto split!: prod.splits btree.splits) apply (auto split!: prod.splits btree.splits)
by (simp add: butlast_inorder_app_id) by (simp add: butlast_inorder_app_id)
next next
...@@ -1241,7 +1246,7 @@ lemma height_bal_subtrees_merge: "\<lbrakk>height (Node as a) = height (Node bs ...@@ -1241,7 +1246,7 @@ lemma height_bal_subtrees_merge: "\<lbrakk>height (Node as a) = height (Node bs
\<Longrightarrow> \<forall>x \<in> set (subtrees as) \<union> {a}. height x = height b" \<Longrightarrow> \<forall>x \<in> set (subtrees as) \<union> {a}. height x = height b"
by (metis Suc_inject Un_iff bal.simps(2) height_bal_tree singletonD) by (metis Suc_inject Un_iff bal.simps(2) height_bal_tree singletonD)
lemma bal_list_merge: lemma bal_list_merge:
assumes "bal_up\<^sub>i (Up\<^sub>i (Node as a) x (Node bs b))" assumes "bal_up\<^sub>i (Up\<^sub>i (Node as a) x (Node bs b))"
shows "bal (Node (as@(a,x)#bs) b)" shows "bal (Node (as@(a,x)#bs) b)"
proof - proof -
...@@ -1257,7 +1262,7 @@ proof - ...@@ -1257,7 +1262,7 @@ proof -
by auto by auto
qed qed
lemma node\<^sub>i_bal_up\<^sub>i: lemma node\<^sub>i_bal_up\<^sub>i:
assumes "bal_up\<^sub>i (node\<^sub>i k ts t)" assumes "bal_up\<^sub>i (node\<^sub>i k ts t)"
shows "bal (Node ts t)" shows "bal (Node ts t)"
using assms using assms
...@@ -1349,14 +1354,14 @@ qed (simp add: height_Leaf) ...@@ -1349,14 +1354,14 @@ qed (simp add: height_Leaf)
lemma rebalance_last_tree_bal: "\<lbrakk>bal (Node ts t); ts \<noteq> []\<rbrakk> \<Longrightarrow> bal (rebalance_last_tree k ts t)" lemma rebalance_last_tree_bal: "\<lbrakk>bal (Node ts t); ts \<noteq> []\<rbrakk> \<Longrightarrow> bal (rebalance_last_tree k ts t)"