8 imports |
8 imports |
9 Isin2 |
9 Isin2 |
10 Cmp |
10 Cmp |
11 begin |
11 begin |
12 |
12 |
13 type_synonym 'a aa_tree = "('a,nat) tree" |
13 type_synonym 'a aa_tree = "('a*nat) tree" |
14 |
14 |
15 definition empty :: "'a aa_tree" where |
15 definition empty :: "'a aa_tree" where |
16 "empty = Leaf" |
16 "empty = Leaf" |
17 |
17 |
18 fun lvl :: "'a aa_tree \<Rightarrow> nat" where |
18 fun lvl :: "'a aa_tree \<Rightarrow> nat" where |
19 "lvl Leaf = 0" | |
19 "lvl Leaf = 0" | |
20 "lvl (Node _ _ lv _) = lv" |
20 "lvl (Node _ (_, lv) _) = lv" |
21 |
21 |
22 fun invar :: "'a aa_tree \<Rightarrow> bool" where |
22 fun invar :: "'a aa_tree \<Rightarrow> bool" where |
23 "invar Leaf = True" | |
23 "invar Leaf = True" | |
24 "invar (Node l a h r) = |
24 "invar (Node l (a, h) r) = |
25 (invar l \<and> invar r \<and> |
25 (invar l \<and> invar r \<and> |
26 h = lvl l + 1 \<and> (h = lvl r + 1 \<or> (\<exists>lr b rr. r = Node lr b h rr \<and> h = lvl rr + 1)))" |
26 h = lvl l + 1 \<and> (h = lvl r + 1 \<or> (\<exists>lr b rr. r = Node lr (b,h) rr \<and> h = lvl rr + 1)))" |
27 |
27 |
28 fun skew :: "'a aa_tree \<Rightarrow> 'a aa_tree" where |
28 fun skew :: "'a aa_tree \<Rightarrow> 'a aa_tree" where |
29 "skew (Node (Node t1 b lvb t2) a lva t3) = |
29 "skew (Node (Node t1 (b, lvb) t2) (a, lva) t3) = |
30 (if lva = lvb then Node t1 b lvb (Node t2 a lva t3) else Node (Node t1 b lvb t2) a lva t3)" | |
30 (if lva = lvb then Node t1 (b, lvb) (Node t2 (a, lva) t3) else Node (Node t1 (b, lvb) t2) (a, lva) t3)" | |
31 "skew t = t" |
31 "skew t = t" |
32 |
32 |
33 fun split :: "'a aa_tree \<Rightarrow> 'a aa_tree" where |
33 fun split :: "'a aa_tree \<Rightarrow> 'a aa_tree" where |
34 "split (Node t1 a lva (Node t2 b lvb (Node t3 c lvc t4))) = |
34 "split (Node t1 (a, lva) (Node t2 (b, lvb) (Node t3 (c, lvc) t4))) = |
35 (if lva = lvb \<and> lvb = lvc \<comment> \<open>\<open>lva = lvc\<close> suffices\<close> |
35 (if lva = lvb \<and> lvb = lvc \<comment> \<open>\<open>lva = lvc\<close> suffices\<close> |
36 then Node (Node t1 a lva t2) b (lva+1) (Node t3 c lva t4) |
36 then Node (Node t1 (a,lva) t2) (b,lva+1) (Node t3 (c, lva) t4) |
37 else Node t1 a lva (Node t2 b lvb (Node t3 c lvc t4)))" | |
37 else Node t1 (a,lva) (Node t2 (b,lvb) (Node t3 (c,lvc) t4)))" | |
38 "split t = t" |
38 "split t = t" |
39 |
39 |
40 hide_const (open) insert |
40 hide_const (open) insert |
41 |
41 |
42 fun insert :: "'a::linorder \<Rightarrow> 'a aa_tree \<Rightarrow> 'a aa_tree" where |
42 fun insert :: "'a::linorder \<Rightarrow> 'a aa_tree \<Rightarrow> 'a aa_tree" where |
43 "insert x Leaf = Node Leaf x 1 Leaf" | |
43 "insert x Leaf = Node Leaf (x, 1) Leaf" | |
44 "insert x (Node t1 a lv t2) = |
44 "insert x (Node t1 (a,lv) t2) = |
45 (case cmp x a of |
45 (case cmp x a of |
46 LT \<Rightarrow> split (skew (Node (insert x t1) a lv t2)) | |
46 LT \<Rightarrow> split (skew (Node (insert x t1) (a,lv) t2)) | |
47 GT \<Rightarrow> split (skew (Node t1 a lv (insert x t2))) | |
47 GT \<Rightarrow> split (skew (Node t1 (a,lv) (insert x t2))) | |
48 EQ \<Rightarrow> Node t1 x lv t2)" |
48 EQ \<Rightarrow> Node t1 (x, lv) t2)" |
49 |
49 |
50 fun sngl :: "'a aa_tree \<Rightarrow> bool" where |
50 fun sngl :: "'a aa_tree \<Rightarrow> bool" where |
51 "sngl Leaf = False" | |
51 "sngl Leaf = False" | |
52 "sngl (Node _ _ _ Leaf) = True" | |
52 "sngl (Node _ _ Leaf) = True" | |
53 "sngl (Node _ _ lva (Node _ _ lvb _)) = (lva > lvb)" |
53 "sngl (Node _ (_, lva) (Node _ (_, lvb) _)) = (lva > lvb)" |
54 |
54 |
55 definition adjust :: "'a aa_tree \<Rightarrow> 'a aa_tree" where |
55 definition adjust :: "'a aa_tree \<Rightarrow> 'a aa_tree" where |
56 "adjust t = |
56 "adjust t = |
57 (case t of |
57 (case t of |
58 Node l x lv r \<Rightarrow> |
58 Node l (x,lv) r \<Rightarrow> |
59 (if lvl l >= lv-1 \<and> lvl r >= lv-1 then t else |
59 (if lvl l >= lv-1 \<and> lvl r >= lv-1 then t else |
60 if lvl r < lv-1 \<and> sngl l then skew (Node l x (lv-1) r) else |
60 if lvl r < lv-1 \<and> sngl l then skew (Node l (x,lv-1) r) else |
61 if lvl r < lv-1 |
61 if lvl r < lv-1 |
62 then case l of |
62 then case l of |
63 Node t1 a lva (Node t2 b lvb t3) |
63 Node t1 (a,lva) (Node t2 (b,lvb) t3) |
64 \<Rightarrow> Node (Node t1 a lva t2) b (lvb+1) (Node t3 x (lv-1) r) |
64 \<Rightarrow> Node (Node t1 (a,lva) t2) (b,lvb+1) (Node t3 (x,lv-1) r) |
65 else |
65 else |
66 if lvl r < lv then split (Node l x (lv-1) r) |
66 if lvl r < lv then split (Node l (x,lv-1) r) |
67 else |
67 else |
68 case r of |
68 case r of |
69 Node t1 b lvb t4 \<Rightarrow> |
69 Node t1 (b,lvb) t4 \<Rightarrow> |
70 (case t1 of |
70 (case t1 of |
71 Node t2 a lva t3 |
71 Node t2 (a,lva) t3 |
72 \<Rightarrow> Node (Node l x (lv-1) t2) a (lva+1) |
72 \<Rightarrow> Node (Node l (x,lv-1) t2) (a,lva+1) |
73 (split (Node t3 b (if sngl t1 then lva else lva+1) t4)))))" |
73 (split (Node t3 (b, if sngl t1 then lva else lva+1) t4)))))" |
74 |
74 |
75 text\<open>In the paper, the last case of \<^const>\<open>adjust\<close> is expressed with the help of an |
75 text\<open>In the paper, the last case of \<^const>\<open>adjust\<close> is expressed with the help of an |
76 incorrect auxiliary function \texttt{nlvl}. |
76 incorrect auxiliary function \texttt{nlvl}. |
77 |
77 |
78 Function \<open>split_max\<close> below is called \texttt{dellrg} in the paper. |
78 Function \<open>split_max\<close> below is called \texttt{dellrg} in the paper. |
79 The latter is incorrect for two reasons: \texttt{dellrg} is meant to delete the largest |
79 The latter is incorrect for two reasons: \texttt{dellrg} is meant to delete the largest |
80 element but recurses on the left instead of the right subtree; the invariant |
80 element but recurses on the left instead of the right subtree; the invariant |
81 is not restored.\<close> |
81 is not restored.\<close> |
82 |
82 |
83 fun split_max :: "'a aa_tree \<Rightarrow> 'a aa_tree * 'a" where |
83 fun split_max :: "'a aa_tree \<Rightarrow> 'a aa_tree * 'a" where |
84 "split_max (Node l a lv Leaf) = (l,a)" | |
84 "split_max (Node l (a,lv) Leaf) = (l,a)" | |
85 "split_max (Node l a lv r) = (let (r',b) = split_max r in (adjust(Node l a lv r'), b))" |
85 "split_max (Node l (a,lv) r) = (let (r',b) = split_max r in (adjust(Node l (a,lv) r'), b))" |
86 |
86 |
87 fun delete :: "'a::linorder \<Rightarrow> 'a aa_tree \<Rightarrow> 'a aa_tree" where |
87 fun delete :: "'a::linorder \<Rightarrow> 'a aa_tree \<Rightarrow> 'a aa_tree" where |
88 "delete _ Leaf = Leaf" | |
88 "delete _ Leaf = Leaf" | |
89 "delete x (Node l a lv r) = |
89 "delete x (Node l (a,lv) r) = |
90 (case cmp x a of |
90 (case cmp x a of |
91 LT \<Rightarrow> adjust (Node (delete x l) a lv r) | |
91 LT \<Rightarrow> adjust (Node (delete x l) (a,lv) r) | |
92 GT \<Rightarrow> adjust (Node l a lv (delete x r)) | |
92 GT \<Rightarrow> adjust (Node l (a,lv) (delete x r)) | |
93 EQ \<Rightarrow> (if l = Leaf then r |
93 EQ \<Rightarrow> (if l = Leaf then r |
94 else let (l',b) = split_max l in adjust (Node l' b lv r)))" |
94 else let (l',b) = split_max l in adjust (Node l' (b,lv) r)))" |
95 |
95 |
96 fun pre_adjust where |
96 fun pre_adjust where |
97 "pre_adjust (Node l a lv r) = (invar l \<and> invar r \<and> |
97 "pre_adjust (Node l (a,lv) r) = (invar l \<and> invar r \<and> |
98 ((lv = lvl l + 1 \<and> (lv = lvl r + 1 \<or> lv = lvl r + 2 \<or> lv = lvl r \<and> sngl r)) \<or> |
98 ((lv = lvl l + 1 \<and> (lv = lvl r + 1 \<or> lv = lvl r + 2 \<or> lv = lvl r \<and> sngl r)) \<or> |
99 (lv = lvl l + 2 \<and> (lv = lvl r + 1 \<or> lv = lvl r \<and> sngl r))))" |
99 (lv = lvl l + 2 \<and> (lv = lvl r + 1 \<or> lv = lvl r \<and> sngl r))))" |
100 |
100 |
101 declare pre_adjust.simps [simp del] |
101 declare pre_adjust.simps [simp del] |
102 |
102 |
103 subsection "Auxiliary Proofs" |
103 subsection "Auxiliary Proofs" |
104 |
104 |
105 lemma split_case: "split t = (case t of |
105 lemma split_case: "split t = (case t of |
106 Node t1 x lvx (Node t2 y lvy (Node t3 z lvz t4)) \<Rightarrow> |
106 Node t1 (x,lvx) (Node t2 (y,lvy) (Node t3 (z,lvz) t4)) \<Rightarrow> |
107 (if lvx = lvy \<and> lvy = lvz |
107 (if lvx = lvy \<and> lvy = lvz |
108 then Node (Node t1 x lvx t2) y (lvx+1) (Node t3 z lvx t4) |
108 then Node (Node t1 (x,lvx) t2) (y,lvx+1) (Node t3 (z,lvx) t4) |
109 else t) |
109 else t) |
110 | t \<Rightarrow> t)" |
110 | t \<Rightarrow> t)" |
111 by(auto split: tree.split) |
111 by(auto split: tree.split) |
112 |
112 |
113 lemma skew_case: "skew t = (case t of |
113 lemma skew_case: "skew t = (case t of |
114 Node (Node t1 y lvy t2) x lvx t3 \<Rightarrow> |
114 Node (Node t1 (y,lvy) t2) (x,lvx) t3 \<Rightarrow> |
115 (if lvx = lvy then Node t1 y lvx (Node t2 x lvx t3) else t) |
115 (if lvx = lvy then Node t1 (y, lvx) (Node t2 (x,lvx) t3) else t) |
116 | t \<Rightarrow> t)" |
116 | t \<Rightarrow> t)" |
117 by(auto split: tree.split) |
117 by(auto split: tree.split) |
118 |
118 |
119 lemma lvl_0_iff: "invar t \<Longrightarrow> lvl t = 0 \<longleftrightarrow> t = Leaf" |
119 lemma lvl_0_iff: "invar t \<Longrightarrow> lvl t = 0 \<longleftrightarrow> t = Leaf" |
120 by(cases t) auto |
120 by(cases t) auto |
121 |
121 |
122 lemma lvl_Suc_iff: "lvl t = Suc n \<longleftrightarrow> (\<exists> l a r. t = Node l a (Suc n) r)" |
122 lemma lvl_Suc_iff: "lvl t = Suc n \<longleftrightarrow> (\<exists> l a r. t = Node l (a,Suc n) r)" |
123 by(cases t) auto |
123 by(cases t) auto |
124 |
124 |
125 lemma lvl_skew: "lvl (skew t) = lvl t" |
125 lemma lvl_skew: "lvl (skew t) = lvl t" |
126 by(cases t rule: skew.cases) auto |
126 by(cases t rule: skew.cases) auto |
127 |
127 |
128 lemma lvl_split: "lvl (split t) = lvl t \<or> lvl (split t) = lvl t + 1 \<and> sngl (split t)" |
128 lemma lvl_split: "lvl (split t) = lvl t \<or> lvl (split t) = lvl t + 1 \<and> sngl (split t)" |
129 by(cases t rule: split.cases) auto |
129 by(cases t rule: split.cases) auto |
130 |
130 |
131 lemma invar_2Nodes:"invar (Node l x lv (Node rl rx rlv rr)) = |
131 lemma invar_2Nodes:"invar (Node l (x,lv) (Node rl (rx, rlv) rr)) = |
132 (invar l \<and> invar \<langle>rl, rx, rlv, rr\<rangle> \<and> lv = Suc (lvl l) \<and> |
132 (invar l \<and> invar \<langle>rl, (rx, rlv), rr\<rangle> \<and> lv = Suc (lvl l) \<and> |
133 (lv = Suc rlv \<or> rlv = lv \<and> lv = Suc (lvl rr)))" |
133 (lv = Suc rlv \<or> rlv = lv \<and> lv = Suc (lvl rr)))" |
134 by simp |
134 by simp |
135 |
135 |
136 lemma invar_NodeLeaf[simp]: |
136 lemma invar_NodeLeaf[simp]: |
137 "invar (Node l x lv Leaf) = (invar l \<and> lv = Suc (lvl l) \<and> lv = Suc 0)" |
137 "invar (Node l (x,lv) Leaf) = (invar l \<and> lv = Suc (lvl l) \<and> lv = Suc 0)" |
138 by simp |
138 by simp |
139 |
139 |
140 lemma sngl_if_invar: "invar (Node l a n r) \<Longrightarrow> n = lvl r \<Longrightarrow> sngl r" |
140 lemma sngl_if_invar: "invar (Node l (a, n) r) \<Longrightarrow> n = lvl r \<Longrightarrow> sngl r" |
141 by(cases r rule: sngl.cases) clarsimp+ |
141 by(cases r rule: sngl.cases) clarsimp+ |
142 |
142 |
143 |
143 |
144 subsection "Invariance" |
144 subsection "Invariance" |
145 |
145 |
181 |
182 |
182 lemma split_invar: "invar t \<Longrightarrow> split t = t" |
183 lemma split_invar: "invar t \<Longrightarrow> split t = t" |
183 by(cases t rule: split.cases) clarsimp+ |
184 by(cases t rule: split.cases) clarsimp+ |
184 |
185 |
185 lemma invar_NodeL: |
186 lemma invar_NodeL: |
186 "\<lbrakk> invar(Node l x n r); invar l'; lvl l' = lvl l \<rbrakk> \<Longrightarrow> invar(Node l' x n r)" |
187 "\<lbrakk> invar(Node l (x, n) r); invar l'; lvl l' = lvl l \<rbrakk> \<Longrightarrow> invar(Node l' (x, n) r)" |
187 by(auto) |
188 by(auto) |
188 |
189 |
189 lemma invar_NodeR: |
190 lemma invar_NodeR: |
190 "\<lbrakk> invar(Node l x n r); n = lvl r + 1; invar r'; lvl r' = lvl r \<rbrakk> \<Longrightarrow> invar(Node l x n r')" |
191 "\<lbrakk> invar(Node l (x, n) r); n = lvl r + 1; invar r'; lvl r' = lvl r \<rbrakk> \<Longrightarrow> invar(Node l (x, n) r')" |
191 by(auto) |
192 by(auto) |
192 |
193 |
193 lemma invar_NodeR2: |
194 lemma invar_NodeR2: |
194 "\<lbrakk> invar(Node l x n r); sngl r'; n = lvl r + 1; invar r'; lvl r' = n \<rbrakk> \<Longrightarrow> invar(Node l x n r')" |
195 "\<lbrakk> invar(Node l (x, n) r); sngl r'; n = lvl r + 1; invar r'; lvl r' = n \<rbrakk> \<Longrightarrow> invar(Node l (x, n) r')" |
195 by(cases r' rule: sngl.cases) clarsimp+ |
196 by(cases r' rule: sngl.cases) clarsimp+ |
196 |
197 |
197 |
198 |
198 lemma lvl_insert_incr_iff: "(lvl(insert a t) = lvl t + 1) \<longleftrightarrow> |
199 lemma lvl_insert_incr_iff: "(lvl(insert a t) = lvl t + 1) \<longleftrightarrow> |
199 (\<exists>l x r. insert a t = Node l x (lvl t + 1) r \<and> lvl l = lvl r)" |
200 (\<exists>l x r. insert a t = Node l (x, lvl t + 1) r \<and> lvl l = lvl r)" |
200 apply(cases t) |
201 apply(cases t rule: tree2_cases) |
201 apply(auto simp add: skew_case split_case split: if_splits) |
202 apply(auto simp add: skew_case split_case split: if_splits) |
202 apply(auto split: tree.splits if_splits) |
203 apply(auto split: tree.splits if_splits) |
203 done |
204 done |
204 |
205 |
205 lemma invar_insert: "invar t \<Longrightarrow> invar(insert a t)" |
206 lemma invar_insert: "invar t \<Longrightarrow> invar(insert a t)" |
206 proof(induction t) |
207 proof(induction t rule: tree2_induct) |
207 case N: (Node l x n r) |
208 case N: (Node l x n r) |
208 hence il: "invar l" and ir: "invar r" by auto |
209 hence il: "invar l" and ir: "invar r" by auto |
209 note iil = N.IH(1)[OF il] |
210 note iil = N.IH(1)[OF il] |
210 note iir = N.IH(2)[OF ir] |
211 note iir = N.IH(2)[OF ir] |
211 let ?t = "Node l x n r" |
212 let ?t = "Node l (x, n) r" |
212 have "a < x \<or> a = x \<or> x < a" by auto |
213 have "a < x \<or> a = x \<or> x < a" by auto |
213 moreover |
214 moreover |
214 have ?case if "a < x" |
215 have ?case if "a < x" |
215 proof (cases rule: lvl_insert[of a l]) |
216 proof (cases rule: lvl_insert[of a l]) |
216 case (Same) thus ?thesis |
217 case (Same) thus ?thesis |
217 using \<open>a<x\<close> invar_NodeL[OF N.prems iil Same] |
218 using \<open>a<x\<close> invar_NodeL[OF N.prems iil Same] |
218 by (simp add: skew_invar split_invar del: invar.simps) |
219 by (simp add: skew_invar split_invar del: invar.simps) |
219 next |
220 next |
220 case (Incr) |
221 case (Incr) |
221 then obtain t1 w t2 where ial[simp]: "insert a l = Node t1 w n t2" |
222 then obtain t1 w t2 where ial[simp]: "insert a l = Node t1 (w, n) t2" |
222 using N.prems by (auto simp: lvl_Suc_iff) |
223 using N.prems by (auto simp: lvl_Suc_iff) |
223 have l12: "lvl t1 = lvl t2" |
224 have l12: "lvl t1 = lvl t2" |
224 by (metis Incr(1) ial lvl_insert_incr_iff tree.inject) |
225 by (metis Incr(1) ial lvl_insert_incr_iff tree.inject) |
225 have "insert a ?t = split(skew(Node (insert a l) x n r))" |
226 have "insert a ?t = split(skew(Node (insert a l) (x,n) r))" |
226 by(simp add: \<open>a<x\<close>) |
227 by(simp add: \<open>a<x\<close>) |
227 also have "skew(Node (insert a l) x n r) = Node t1 w n (Node t2 x n r)" |
228 also have "skew(Node (insert a l) (x,n) r) = Node t1 (w,n) (Node t2 (x,n) r)" |
228 by(simp) |
229 by(simp) |
229 also have "invar(split \<dots>)" |
230 also have "invar(split \<dots>)" |
230 proof (cases r) |
231 proof (cases r rule: tree2_cases) |
231 case Leaf |
232 case Leaf |
232 hence "l = Leaf" using N.prems by(auto simp: lvl_0_iff) |
233 hence "l = Leaf" using N.prems by(auto simp: lvl_0_iff) |
233 thus ?thesis using Leaf ial by simp |
234 thus ?thesis using Leaf ial by simp |
234 next |
235 next |
235 case [simp]: (Node t3 y m t4) |
236 case [simp]: (Node t3 y m t4) |
315 by auto |
316 by auto |
316 |
317 |
317 declare invar.simps(2)[simp del] invar_2Nodes[simp add] |
318 declare invar.simps(2)[simp del] invar_2Nodes[simp add] |
318 |
319 |
319 lemma invar_adjust: |
320 lemma invar_adjust: |
320 assumes pre: "pre_adjust (Node l a lv r)" |
321 assumes pre: "pre_adjust (Node l (a,lv) r)" |
321 shows "invar(adjust (Node l a lv r))" |
322 shows "invar(adjust (Node l (a,lv) r))" |
322 using pre proof (cases rule: pre_cases) |
323 using pre proof (cases rule: pre_cases) |
323 case (tDouble) thus ?thesis unfolding adjust_def by (cases r) (auto simp: invar.simps(2)) |
324 case (tDouble) thus ?thesis unfolding adjust_def by (cases r) (auto simp: invar.simps(2)) |
324 next |
325 next |
325 case (rDown) |
326 case (rDown) |
326 from rDown obtain llv ll la lr where l: "l = Node ll la llv lr" by (cases l) auto |
327 from rDown obtain llv ll la lr where l: "l = Node ll (la, llv) lr" by (cases l) auto |
327 from rDown show ?thesis unfolding adjust_def by (auto simp: l invar.simps(2) split: tree.splits) |
328 from rDown show ?thesis unfolding adjust_def by (auto simp: l invar.simps(2) split: tree.splits) |
328 next |
329 next |
329 case (lDown_tDouble) |
330 case (lDown_tDouble) |
330 from lDown_tDouble obtain rlv rr ra rl where r: "r = Node rl ra rlv rr" by (cases r) auto |
331 from lDown_tDouble obtain rlv rr ra rl where r: "r = Node rl (ra, rlv) rr" by (cases r) auto |
331 from lDown_tDouble and r obtain rrlv rrr rra rrl where |
332 from lDown_tDouble and r obtain rrlv rrr rra rrl where |
332 rr :"rr = Node rrr rra rrlv rrl" by (cases rr) auto |
333 rr :"rr = Node rrr (rra, rrlv) rrl" by (cases rr) auto |
333 from lDown_tDouble show ?thesis unfolding adjust_def r rr |
334 from lDown_tDouble show ?thesis unfolding adjust_def r rr |
334 apply (cases rl) apply (auto simp add: invar.simps(2) split!: if_split) |
335 apply (cases rl rule: tree2_cases) apply (auto simp add: invar.simps(2) split!: if_split) |
335 using lDown_tDouble by (auto simp: split_case lvl_0_iff elim:lvl.elims split: tree.split) |
336 using lDown_tDouble by (auto simp: split_case lvl_0_iff elim:lvl.elims split: tree.split) |
336 qed (auto simp: split_case invar.simps(2) adjust_def split: tree.splits) |
337 qed (auto simp: split_case invar.simps(2) adjust_def split: tree.splits) |
337 |
338 |
338 lemma lvl_adjust: |
339 lemma lvl_adjust: |
339 assumes "pre_adjust (Node l a lv r)" |
340 assumes "pre_adjust (Node l (a,lv) r)" |
340 shows "lv = lvl (adjust(Node l a lv r)) \<or> lv = lvl (adjust(Node l a lv r)) + 1" |
341 shows "lv = lvl (adjust(Node l (a,lv) r)) \<or> lv = lvl (adjust(Node l (a,lv) r)) + 1" |
341 using assms(1) proof(cases rule: pre_cases) |
342 using assms(1) |
|
343 proof(cases rule: pre_cases) |
342 case lDown_tSngl thus ?thesis |
344 case lDown_tSngl thus ?thesis |
343 using lvl_split[of "\<langle>l, a, lvl r, r\<rangle>"] by (auto simp: adjust_def) |
345 using lvl_split[of "\<langle>l, (a, lvl r), r\<rangle>"] by (auto simp: adjust_def) |
344 next |
346 next |
345 case lDown_tDouble thus ?thesis |
347 case lDown_tDouble thus ?thesis |
346 by (auto simp: adjust_def invar.simps(2) split: tree.split) |
348 by (auto simp: adjust_def invar.simps(2) split: tree.split) |
347 qed (auto simp: adjust_def split: tree.splits) |
349 qed (auto simp: adjust_def split: tree.splits) |
348 |
350 |
349 lemma sngl_adjust: assumes "pre_adjust (Node l a lv r)" |
351 lemma sngl_adjust: assumes "pre_adjust (Node l (a,lv) r)" |
350 "sngl \<langle>l, a, lv, r\<rangle>" "lv = lvl (adjust \<langle>l, a, lv, r\<rangle>)" |
352 "sngl \<langle>l, (a, lv), r\<rangle>" "lv = lvl (adjust \<langle>l, (a, lv), r\<rangle>)" |
351 shows "sngl (adjust \<langle>l, a, lv, r\<rangle>)" |
353 shows "sngl (adjust \<langle>l, (a, lv), r\<rangle>)" |
352 using assms proof (cases rule: pre_cases) |
354 using assms proof (cases rule: pre_cases) |
353 case rDown |
355 case rDown |
354 thus ?thesis using assms(2,3) unfolding adjust_def |
356 thus ?thesis using assms(2,3) unfolding adjust_def |
355 by (auto simp add: skew_case) (auto split: tree.split) |
357 by (auto simp add: skew_case) (auto split: tree.split) |
356 qed (auto simp: adjust_def skew_case split_case split: tree.split) |
358 qed (auto simp: adjust_def skew_case split_case split: tree.split) |
359 invar t' \<and> |
361 invar t' \<and> |
360 (lvl t' = lvl t \<or> lvl t' + 1 = lvl t) \<and> |
362 (lvl t' = lvl t \<or> lvl t' + 1 = lvl t) \<and> |
361 (lvl t' = lvl t \<and> sngl t \<longrightarrow> sngl t')" |
363 (lvl t' = lvl t \<and> sngl t \<longrightarrow> sngl t')" |
362 |
364 |
363 lemma pre_adj_if_postR: |
365 lemma pre_adj_if_postR: |
364 "invar\<langle>lv, l, a, r\<rangle> \<Longrightarrow> post_del r r' \<Longrightarrow> pre_adjust \<langle>lv, l, a, r'\<rangle>" |
366 "invar\<langle>lv, (l, a), r\<rangle> \<Longrightarrow> post_del r r' \<Longrightarrow> pre_adjust \<langle>lv, (l, a), r'\<rangle>" |
365 by(cases "sngl r") |
367 by(cases "sngl r") |
366 (auto simp: pre_adjust.simps post_del_def invar.simps(2) elim: sngl.elims) |
368 (auto simp: pre_adjust.simps post_del_def invar.simps(2) elim: sngl.elims) |
367 |
369 |
368 lemma pre_adj_if_postL: |
370 lemma pre_adj_if_postL: |
369 "invar\<langle>l, a, lv, r\<rangle> \<Longrightarrow> post_del l l' \<Longrightarrow> pre_adjust \<langle>l', b, lv, r\<rangle>" |
371 "invar\<langle>l, (a, lv), r\<rangle> \<Longrightarrow> post_del l l' \<Longrightarrow> pre_adjust \<langle>l', (b, lv), r\<rangle>" |
370 by(cases "sngl r") |
372 by(cases "sngl r") |
371 (auto simp: pre_adjust.simps post_del_def invar.simps(2) elim: sngl.elims) |
373 (auto simp: pre_adjust.simps post_del_def invar.simps(2) elim: sngl.elims) |
372 |
374 |
373 lemma post_del_adjL: |
375 lemma post_del_adjL: |
374 "\<lbrakk> invar\<langle>l, a, lv, r\<rangle>; pre_adjust \<langle>l', b, lv, r\<rangle> \<rbrakk> |
376 "\<lbrakk> invar\<langle>l, (a, lv), r\<rangle>; pre_adjust \<langle>l', (b, lv), r\<rangle> \<rbrakk> |
375 \<Longrightarrow> post_del \<langle>l, a, lv, r\<rangle> (adjust \<langle>l', b, lv, r\<rangle>)" |
377 \<Longrightarrow> post_del \<langle>l, (a, lv), r\<rangle> (adjust \<langle>l', (b, lv), r\<rangle>)" |
376 unfolding post_del_def |
378 unfolding post_del_def |
377 by (metis invar_adjust lvl_adjust sngl_NodeI sngl_adjust lvl.simps(2)) |
379 by (metis invar_adjust lvl_adjust sngl_NodeI sngl_adjust lvl.simps(2)) |
378 |
380 |
379 lemma post_del_adjR: |
381 lemma post_del_adjR: |
380 assumes "invar\<langle>lv, l, a, r\<rangle>" "pre_adjust \<langle>lv, l, a, r'\<rangle>" "post_del r r'" |
382 assumes "invar\<langle>l, (a,lv), r\<rangle>" "pre_adjust \<langle>l, (a,lv), r'\<rangle>" "post_del r r'" |
381 shows "post_del \<langle>lv, l, a, r\<rangle> (adjust \<langle>lv, l, a, r'\<rangle>)" |
383 shows "post_del \<langle>l, (a,lv), r\<rangle> (adjust \<langle>l, (a,lv), r'\<rangle>)" |
382 proof(unfold post_del_def, safe del: disjCI) |
384 proof(unfold post_del_def, safe del: disjCI) |
383 let ?t = "\<langle>lv, l, a, r\<rangle>" |
385 let ?t = "\<langle>l, (a,lv), r\<rangle>" |
384 let ?t' = "adjust \<langle>lv, l, a, r'\<rangle>" |
386 let ?t' = "adjust \<langle>l, (a,lv), r'\<rangle>" |
385 show "invar ?t'" by(rule invar_adjust[OF assms(2)]) |
387 show "invar ?t'" by(rule invar_adjust[OF assms(2)]) |
386 show "lvl ?t' = lvl ?t \<or> lvl ?t' + 1 = lvl ?t" |
388 show "lvl ?t' = lvl ?t \<or> lvl ?t' + 1 = lvl ?t" |
387 using lvl_adjust[OF assms(2)] by auto |
389 using lvl_adjust[OF assms(2)] by auto |
388 show "sngl ?t'" if as: "lvl ?t' = lvl ?t" "sngl ?t" |
390 show "sngl ?t'" if as: "lvl ?t' = lvl ?t" "sngl ?t" |
389 proof - |
391 proof - |
390 have s: "sngl \<langle>lv, l, a, r'\<rangle>" |
392 have s: "sngl \<langle>l, (a,lv), r'\<rangle>" |
391 proof(cases r') |
393 proof(cases r' rule: tree2_cases) |
392 case Leaf thus ?thesis by simp |
394 case Leaf thus ?thesis by simp |
393 next |
395 next |
394 case Node thus ?thesis using as(2) assms(1,3) |
396 case Node thus ?thesis using as(2) assms(1,3) |
395 by (cases r) (auto simp: post_del_def) |
397 by (cases r rule: tree2_cases) (auto simp: post_del_def) |
396 qed |
398 qed |
397 show ?thesis using as(1) sngl_adjust[OF assms(2) s] by simp |
399 show ?thesis using as(1) sngl_adjust[OF assms(2) s] by simp |
398 qed |
400 qed |
399 qed |
401 qed |
400 |
402 |
401 declare prod.splits[split] |
403 declare prod.splits[split] |
402 |
404 |
403 theorem post_split_max: |
405 theorem post_split_max: |
404 "\<lbrakk> invar t; (t', x) = split_max t; t \<noteq> Leaf \<rbrakk> \<Longrightarrow> post_del t t'" |
406 "\<lbrakk> invar t; (t', x) = split_max t; t \<noteq> Leaf \<rbrakk> \<Longrightarrow> post_del t t'" |
405 proof (induction t arbitrary: t' rule: split_max.induct) |
407 proof (induction t arbitrary: t' rule: split_max.induct) |
406 case (2 lv l a lvr rl ra rr) |
408 case (2 l a lv rl bl rr) |
407 let ?r = "\<langle>lvr, rl, ra, rr\<rangle>" |
409 let ?r = "\<langle>rl, bl, rr\<rangle>" |
408 let ?t = "\<langle>lv, l, a, ?r\<rangle>" |
410 let ?t = "\<langle>l, (a, lv), ?r\<rangle>" |
409 from "2.prems"(2) obtain r' where r': "(r', x) = split_max ?r" |
411 from "2.prems"(2) obtain r' where r': "(r', x) = split_max ?r" |
410 and [simp]: "t' = adjust \<langle>lv, l, a, r'\<rangle>" by auto |
412 and [simp]: "t' = adjust \<langle>l, (a, lv), r'\<rangle>" by auto |
411 from "2.IH"[OF _ r'] \<open>invar ?t\<close> have post: "post_del ?r r'" by simp |
413 from "2.IH"[OF _ r'] \<open>invar ?t\<close> have post: "post_del ?r r'" by simp |
412 note preR = pre_adj_if_postR[OF \<open>invar ?t\<close> post] |
414 note preR = pre_adj_if_postR[OF \<open>invar ?t\<close> post] |
413 show ?case by (simp add: post_del_adjR[OF "2.prems"(1) preR post]) |
415 show ?case by (simp add: post_del_adjR[OF "2.prems"(1) preR post]) |
414 qed (auto simp: post_del_def) |
416 qed (auto simp: post_del_def) |
415 |
417 |
416 theorem post_delete: "invar t \<Longrightarrow> post_del t (delete x t)" |
418 theorem post_delete: "invar t \<Longrightarrow> post_del t (delete x t)" |
417 proof (induction t) |
419 proof (induction t rule: tree2_induct) |
418 case (Node l a lv r) |
420 case (Node l a lv r) |
419 |
421 |
420 let ?l' = "delete x l" and ?r' = "delete x r" |
422 let ?l' = "delete x l" and ?r' = "delete x r" |
421 let ?t = "Node l a lv r" let ?t' = "delete x ?t" |
423 let ?t = "Node l (a,lv) r" let ?t' = "delete x ?t" |
422 |
424 |
423 from Node.prems have inv_l: "invar l" and inv_r: "invar r" by (auto) |
425 from Node.prems have inv_l: "invar l" and inv_r: "invar r" by (auto) |
424 |
426 |
425 note post_l' = Node.IH(1)[OF inv_l] |
427 note post_l' = Node.IH(1)[OF inv_l] |
426 note preL = pre_adj_if_postL[OF Node.prems post_l'] |
428 note preL = pre_adj_if_postL[OF Node.prems post_l'] |