Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 560 lines (518 sloc) 14.482 kb
da21d13 Add comment: coq version
Yoichi Hirai authored
1 (* USAGE
2 * $ coqc --version
3 * The Coq Proof Assistant, version 8.3pl2 (August 2011)
4 * compiled on Aug 25 2011 04:21:44 with OCaml 3.12.0
5 * $ time coqc -opt llrbtree.v
6 * real 6m49.834s
7 * user 6m47.449s
8 * sys 0m2.208s
9 *)
10
fda4a52 Kazu Yamamoto adding Hirai's proof in Coq.
authored
11 Inductive Color : Set := R | B.
12
13 Section RB.
14
15 Parameter a : Set.
16
17 Inductive RBTree :=
18 | Leaf
19 | Fork : Color -> RBTree -> a -> RBTree -> RBTree.
20
21 Definition empty := Leaf.
22
23 Inductive hasSameBlackDepth : nat -> RBTree -> Prop :=
24 | Oleaf : hasSameBlackDepth O Leaf
25 | SforkB : forall (l r: RBTree) (m: nat) (x: a),
26 hasSameBlackDepth m l -> hasSameBlackDepth m r ->
27 hasSameBlackDepth (S m) (Fork B l x r)
28 | SforkR : forall (l r: RBTree) (m: nat) (x: a),
29 hasSameBlackDepth m l -> hasSameBlackDepth m r ->
30 hasSameBlackDepth m (Fork R l x r).
31
32 Definition isBlackSame (t: RBTree): Prop :=
33 exists n: nat, hasSameBlackDepth n t.
34
35
36 Fixpoint reds (c: Color) (t: RBTree) : bool :=
37 match (c, t) with
38 | (_, Leaf) => true
39 | (R, Fork R _ _ _) => false
40 | (_, Fork c l _ r) => andb (reds c l) (reds c r)
41 end.
42
43 Definition isRedSeparate (t: RBTree) :=
44 is_true (reds B t).
45
46 Definition isBalanced (t: RBTree): Prop :=
47 isBlackSame t /\ isRedSeparate t.
48
49 Inductive cmp := LT | GT | EQ.
50 Parameter compare : a -> a -> cmp.
51
52 Definition balanceL c l x r :=
53 match (c,l,x,r) with
54 | (B, (Fork R (Fork R a x b) y c), z, d) =>
55 Fork R (Fork B a x b) y (Fork B c z d)
56 | (c, a, x, b) => Fork c a x b
57 end.
58
59 Definition balanceR c l x r :=
60 match (c,l,x,r) with
61 | (B, (Fork R a x b), y, (Fork R c z d)) =>
62 Fork R (Fork B a x b) y (Fork B c z d)
63 | (k, x, y, (Fork R c z d)) =>
64 Fork k (Fork R x y c) z d
65 | (c, a, x, b) => Fork c a x b
66 end.
67
68 Fixpoint ins x t :=
69 match t with
70 | Leaf => Fork R Leaf x Leaf
71 | Fork c l y r =>
72 match compare x y with
73 | LT => balanceL c (ins x l) y r
74 | GT => balanceR c l y (ins x r)
75 | EQ => t
76 end
77 end.
78
79 Definition insert a b :=
80 match ins a b with
81 | Fork _ d e f => Fork B d e f
82 | Leaf => (* never reached *) Leaf
83 end.
84
85 Fixpoint isLeftLean t :=
86 match t with
87 | Leaf => true
88 | (Fork B _ _ (Fork R _ _ _)) => false
89 | (Fork _ r _ l) => andb (isLeftLean r) (isLeftLean l)
90 end.
91
92 Definition valid t :=
93 isBalanced t /\ is_true (isLeftLean t).
94
95 Lemma redsRB: forall t1,
96 reds R t1 = true -> reds B t1 = true.
97 destruct t1; intuition.
98 inversion H.
99 case_eq c.
100 intro.
101 subst.
102 congruence.
103
104 intro.
105 subst.
106 apply andb_prop in H1.
107 destruct H1.
108 simpl.
109 reflexivity.
110
111 Qed.
112
113 Lemma hasSameFunctional: forall t m m0,
114 hasSameBlackDepth m t ->
115 hasSameBlackDepth m0 t -> m = m0.
116 induction t.
117 intuition.
118 inversion H.
119 inversion H0.
120 auto.
121
122 intros.
123 inversion H; subst.
124 inversion H0; subst.
125
126 intuition.
127
128 inversion H; subst.
129 inversion H0; subst.
130
131 intuition.
132
133 Qed.
134
135 Lemma ins_result_not_leaf: forall x t, ins x t = Leaf -> False.
136 intro x.
137 induction t.
138 simpl.
139 congruence.
140 simpl.
141 destruct (compare x a0).
142 case (ins x t1).
143 unfold balanceL.
144 case c.
145 congruence.
146 congruence.
147 intro.
148
149 intro.
150 intro.
151 intro.
152 unfold balanceL.
153 case c.
154 congruence.
155 case c0.
156 case r.
157 congruence.
158 intros.
159 destruct c1.
160 congruence.
161 congruence.
162 congruence.
163 unfold balanceR.
164 destruct c.
165 destruct (ins x t2); try congruence.
166 destruct c; try congruence.
167 destruct t2; try destruct (ins x t2); try destruct t1; try congruence.
168 simpl.
169 congruence.
170 destruct c.
171 simpl.
172 congruence.
173 simpl; congruence.
174 destruct c; simpl; try congruence.
175 destruct (compare x a1).
176 destruct (balanceL R (ins x t2_1) a1 t2_2).
177 congruence.
178 destruct c.
179 congruence.
180 congruence.
181 destruct (balanceR R t2_1 a1 (ins x t2_2)); try destruct c; try congruence.
182 congruence.
183 destruct (compare x a1); try destruct (balanceL B (ins x t2_1) a1 t2_2); try destruct (balanceR B t2_1 a1 (ins x t2_2)); try destruct c; try destruct c0; try congruence.
184 destruct c0.
185 destruct (ins x (Fork c t2_1 a1 t2_2)); try destruct c0; try congruence.
186 destruct (ins x (Fork c t2_1 a1 t2_2)); try destruct c0; try congruence.
187 congruence.
188
189 Qed.
190
191
192 Ltac pira :=
193 unfold is_true, empty, isBalanced, isBlackSame, isRedSeparate, balanceL, balanceR in *; simpl in *; auto; try congruence;
194 match goal with
195 (* killing *)
196 | [|- hasSameBlackDepth O Leaf] => apply Oleaf
197 | [H :ins ?x ?t1 = Leaf |- _] => clear - H; apply False_ind; apply ins_result_not_leaf with x t1
198 (* context_non_splitting *)
199 | [H: ?m = ?m, H1: ?m = ?m |- _] =>
200 clear H1
201 | [|- _ -> _] => intro
202 | [IH : valid ?t -> valid (insert ?x ?t) |- _] => destruct IH
203 | [IH : context[valid _] |- _] => unfold valid in IH
204 | [|- context[valid _] ] => unfold valid
205 | [IH : context[insert _ _] |- _] => unfold insert in IH
206 | [|- context[insert _ _] ] => unfold insert
207 | [H: exists n, _ |- _] => destruct H
208 | [|- exists m: nat, hasSameBlackDepth m Leaf] => exists O
209 | [|- exists n : nat, hasSameBlackDepth n (Fork R Leaf _ _)] => exists O
210 | [|- exists n : nat, hasSameBlackDepth n (Fork B Leaf _ _)] => exists (S O)
211 | [|- exists n : nat, hasSameBlackDepth n (Fork R _ _ Leaf)] => exists O
212 | [|- exists n : nat, hasSameBlackDepth n (Fork B _ _ Leaf)] => exists (S O)
213 | [|- exists n : nat, hasSameBlackDepth n (Fork B (Fork R Leaf _ _) _ _)] =>
214 exists (S O)
215 | [|- exists n : nat, hasSameBlackDepth n (Fork B (Fork R _ _ Leaf) _ _)] =>
216 exists (S O)
217 | [|- exists n : nat, hasSameBlackDepth n
218 (Fork R (Fork B (Fork R Leaf _ _) _ _) _ _)] => exists (S O)
219 | [|- exists n : nat, hasSameBlackDepth n
220 (Fork R (Fork B (Fork R _ _ Leaf) _ _) _ _)] => exists (S O)
221 | [|- context[reds _ Leaf]] => simpl
222 | [H: _ /\ _ |- _] => destruct H
223 | [H: hasSameBlackDepth ?x0 ?t1 |- exists n, hasSameBlackDepth n ?t1]
224 => exists x0
225 | [H: (?a && ?b)%bool = true |- _] => apply andb_prop in H
226 (* | [H: ?a = true |- _] => rewrite H in * *)
227 | [H : reds R ?t1 = true |- reds B ?t1 = true] => apply redsRB
228 | [H: hasSameBlackDepth ?m ?t, H0: hasSameBlackDepth ?n ?t |- _] =>
229 progress (
230 first[
231 match goal with
232 | [H1: m = n |- _] => idtac
233 end |
234 (assert (m = n) by (apply hasSameFunctional with t; auto); subst)])
235 | [H :ins ?x ?t = Fork _ _ _ _ |- _] => rewrite H in *
236 | [ H: hasSameBlackDepth ?x ?t1 |-
237 exists n : nat, hasSameBlackDepth n (Fork R (Fork R ?t1 _ _) _ _)]
238 =>
239 exists x
240 | [ |- exists n : nat, hasSameBlackDepth n (Fork R (Fork R Leaf _ Leaf) _ Leaf)] =>
241 exists O
242 | [ H31 : hasSameBlackDepth ?x ?r1 |- exists n : nat,
243 hasSameBlackDepth n
244 (Fork B (Fork R (Fork B ?r1 _ _) _ _)_ _)] =>
245 exists (S (S x))
246 | [ H31 : hasSameBlackDepth ?m1 ?r2 |-
247 exists n : nat,
248 hasSameBlackDepth n
249 (Fork B (Fork R _ _ (Fork B _ _ ?r2)) _ _)] =>
250 exists (S (S m1))
251 | [ H31 : hasSameBlackDepth ?x ?r1 |- exists n : nat,
252 hasSameBlackDepth n
253 (Fork R (Fork B (Fork B ?r1 _ _) _ _)_ _)] =>
254 exists (S (S x))
255 | [ H33 : hasSameBlackDepth ?x ?r1 |-
256 exists n : nat,
257 hasSameBlackDepth n
258 (Fork B (Fork B _ _ ?r1) _ _)] =>
259 exists (S (S x))
260 | [ H31 : hasSameBlackDepth ?x ?r1 |- exists n : nat,
261 hasSameBlackDepth n
262 (Fork B (Fork B (Fork R ?r1 _ _) _ _)_ _)] =>
263 exists (S (S x))
264 | [ H31 : hasSameBlackDepth ?x ?r1 |- exists n : nat,
265 hasSameBlackDepth n
266 (Fork B (Fork B (Fork B ?r1 _ _) _ _)_ _)] =>
267 exists (S (S (S x)))
268 | [H: hasSameBlackDepth _ (Fork _ _ _ _) |- _] =>
269 inversion H; clear H; subst
270 | [H: reds _ (Fork _ _ _ _) = _ |- _] =>
271 inversion H; clear H; subst
272 | [H: (isLeftLean (Fork _ _ _ _)) = true |- _] =>
273 inversion H; clear H; subst
274 | [H14 : hasSameBlackDepth _ Leaf |- _] =>
275 inversion H14; clear H14; subst
276 | [ H11 : Fork _ _ _ _ = Fork _ _ _ _ |- _] =>
277 inversion H11; clear H11; subst
278 (* context_splitting *)
279 | [|- andb _ _ = true] => apply andb_true_intro
280 | [|- _ /\ _] => split
281 | [c : Color |-_] => case_eq c; subst
282 | [H : hasSameBlackDepth ?x ?t |- exists n : nat, hasSameBlackDepth n (Fork B ?t _ _)] => exists (S x)
283 | [H : hasSameBlackDepth ?x ?t |- exists n : nat, hasSameBlackDepth n (Fork R ?t _ _)] => exists x
284 | [|- hasSameBlackDepth (S _) (Fork B _ _ _)] => apply SforkB
285 | [H := ?x : nat |- hasSameBlackDepth ?x (Fork B _ _ _)] => destruct x
286 | [|- hasSameBlackDepth _ (Fork R _ _ _)] => apply SforkR
287 | [H := ?x : nat |- hasSameBlackDepth ?x Leaf] => destruct x
288 | [|- context[compare ?a ?b]] => destruct (compare a b)
289 | [H: context[compare ?a ?b] |- _ ] => destruct (compare a b)
290 | [|- context [isLeftLean Leaf]] => simpl
291 | [|- context [isLeftLean (Fork _ _ _)] ] => simpl
292 (* too heavy *)
293 (* undecided *)
294 (* | [H14 : hasSameBlackDepth 0 _ |- _] =>
295 inversion H14; clear H14; subst causes inf loop *)
296 end
297 .
298
299 Ltac pirapira := progress (repeat pira).
300 Ltac finish := abstract pirapira.
301
302 Lemma valid_empty: valid empty.
303 pirapira.
304 Qed.
305
306 Ltac c x t :=
307 case_eq (ins x t).
308
309 Ltac d t :=
310 destruct t.
311
312 Ltac a :=
313 try finish; pirapira.
314
315 Lemma valid_insert: forall x t, valid t -> valid (insert x t).
316 intro x; induction t; a.
317
318 d t2; finish.
319 d t2; finish.
320 d t2; finish.
321 d t1; a.
322 c x t1_1; a.
323 d r; a.
324 d t1_1; a; c x t1_2; a.
325 c x t1_1; a.
326 c x t1_2; a.
327 d t1_1; a.
328 d t1_1; a.
329 Focus 12.
330 d t1; a; d t2; a.
331 Unfocus.
332 Focus 11.
333 d t1; a; d t2; a.
334 c x t2_1; a.
335 d r; a.
336 d t2_1; a; c x t2_2; a.
337 c x t2_1; a.
338 d r; a.
339 d t2_1; c x t2_2;a.
340 c x t2_1; a.
341 d r; a.
342 d t2_1; a; c x t2_2; a.
343 Unfocus.
344 Focus 10.
345 d t1; a.
346 d t2; a.
347 d t2; a.
348 c x t1_1; a.
349 d r; a.
350 c x t1_1;a.
351 d r;a.
352 c x t1_1;a.
353 d r;a.
354 d t2; a; c x t1_2; a.
355 d t1_1;a.
356 d t1_1;a.
357 d t1_1;a.
358 d t1_1;a.
359 d t1_1;a.
360 d t1_1;a.
361 d t2; a; d t1_2; a.
362 Unfocus.
363 Focus 9.
364 d t2; a.
365 c x t2_1;a.
366 d r;a.
367 d t2_1; a; c x t2_2; a.
368 Unfocus.
369 Focus 8.
370 d t1; a.
371 c x t1_1;a.
372 d r;a.
373 d t1_1; a; c x t1_2; a.
374 Unfocus.
375 Focus 7.
376 d t2; a.
377 c x t2_1; a.
378 d r; a.
379 d t2_1; a; c x t2_2; a.
380 Unfocus.
381 Focus 6.
382 d t1; a.
383 c x t1_1;a.
384 d r;a.
385 d t1_1;a; c x t1_2; a.
386 Unfocus.
387 Focus 5.
388 d t1; a.
389 d t2; a.
390 d t2; a.
391 c x t2_1;a.
392 d r;a.
393 d t2_1; a; c x t2_2;a.
394 d t2; a.
395 c x t2_1; a.
396 d r;a.
397 d t2_1; a; c x t2_2; a.
398 d t2; a.
399 c x t2_1;a.
400 d r;a.
401 d t2_1;a; c x t2_2; a.
402 d t2; a.
403 d t1_2; a.
404 c x t2_1; a.
405 d r;a.
406 d t1_2;a.
407 d t2_1; a; c x t2_2; a.
408 d t1_2; a.
409 d t2; a.
410 d t1_2; a.
411 c x t2_1; a.
412 d r;a.
413 d t1_2;a.
414 d t2_1;a.
415 c x t2_2;a.
416 c x t2_2;a.
417 c x t2_2;a.
418 d t1_2;a.
419 d t2;a.
420 c x t2_1;a.
421 d r;a.
422 d t2_1;a.
423 c x t2_2;a.
424 c x t2_2;a.
425 c x t2_2;a.
426 Unfocus.
427 Focus 4.
428 d t1; a.
429 c x t1_1;a.
430 d r;a.
431 d t2;a;d t1_2;a.
432 d t2;a.
433 d t2;a.
434 d t2;a.
435 d t1_1; a; c x t1_2; a.
436 d t2;a; d r0; a.
437 d t2; a; d r0; a; d t1_1_2; a.
438 d t2; a; d r0; a; d t1_1_2; a.
439 d t2; a; d t1_1_2; a; d r0; a.
440 d t2; a; d r0; a.
441 c x t1_1; a.
442 d t1_2; a.
443 d t2; a; d r0; a; d t1_2_2; a.
444 d r0; a.
445 d t2; a; d t1_2; a.
446 d t1_2; a; d r0_2; a.
447 d r0_2; a.
448 d t1_2; a.
449 d t1_2; a.
450 d t1_2; a.
451 d t1_2; a.
452
453 d t2;a.
454 c x t1_2; a.
455 d r;a.
456 d r0;a.
457 d r0; a; d r2; a.
458 d r2; a.
459 d r0;a.
460 d r0;a.
461 d r2_2; a.
462 d r0;a.
463 d r0; a.
464 d r0;a.
465 d r0;a.
466 d r0;a.
467 d t2; a.
468 d r0; a.
469 d r0;a.
470 d r0;a.
471 d r0;a.
472 d t1_1;a.
473 d t2; a; d t1_1_2;a.
474 d t1_1;a.
475 Unfocus.
476 Focus 3.
477 d t1; a; d t2; a.
478 c x t2_1; a.
479 d r;a.
480 d t2_1;a.
481 c x t2_2;a.
482 c x t2_2;a.
483 c x t2_2;a.
484 c x t2_1;a.
485 d r;a.
486 d t2_1; a; c x t2_2; a.
487 c x t2_1;a.
488 d r;a.
489 d t2_1; a;c x t2_2;a.
490 c x t2_1; a.
491 d r;a.
492 d t2_1; a; c x t2_2; a.
493 c x t2_1; a.
494 d r; a.
495 d t2_1; a; c x t2_2; a.
496 c x t2_1; a.
497 d r;a.
498 d t2_1; a; c x t2_2; a.
499 Unfocus.
500 Focus 2.
501 d t1; a.
502 c x t1_1; a.
503 d r;a.
504 d t1_1; c x t1_2; a.
505 c x t1_1; a.
506 c x t1_2; a.
507 d t1_1;a.
508 d t1_1;a.
509 Unfocus.
510 d t1; a; d t2; a.
511 c x t2_1;a.
512 d r;a.
513 d t2_1; a; c x t2_2;a.
514 c x t2_1; a.
515 d r;a.
516 d t2_1;a; c x t2_2;a.
517 c x t2_1; a.
518 d r;a.
519 d t2_1; a; c x t2_2;a.
520 c x t2_1; a.
521 d r;a.
522 exists 2; a.
523 exists (S (S (S m))); a.
524 exists (S (S (S m))); a.
525 Focus 2.
526 exists (S (S m0)); a.
527 Unfocus.
528 Focus 7.
529 exists (S (S m0)); a.
530 Unfocus.
531 d t2_1; a; c x t2_2;a.
532 exists 2; a.
533 exists (S (S (S m1))); a.
534 exists (S (S (S m1))); a.
535 exists (S (S (S m1))); a.
536 c x t2_1; a.
537 d r;a.
538 exists 2; a.
539 exists (S (S (S m0))); a.
540 exists (S (S (S m0))); a.
541 d t2_1; a; c x t2_2; a.
542 exists 2; a.
543 exists (S (S (S m1))); a.
544 exists (S (S (S m1))); a.
545 exists (S (S (S m1))); a.
546 exists (S (S m)); a.
547 c x t2_1; a.
548 d r;a.
549 exists 2; a.
550 exists (S (S (S m))); a.
551 exists (S (S (S m))); a.
552 d t2_1; a; c x t2_2; a.
553 exists 2; a.
554 exists (S (S (S m1))); a.
555 exists (S (S (S m1))); a.
556 exists (S (S (S m1))); a.
557 Qed.
da21d13 Add comment: coq version
Yoichi Hirai authored
558
559 End RB.
Something went wrong with that request. Please try again.