]>
Commit | Line | Data |
---|---|---|
4c2d6a70 AC |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT LIBRARY COMPONENTS -- | |
4 | -- -- | |
8704d4b3 MH |
5 | -- A D A . C O N T A I N E R S . R E D _ B L A C K _ T R E E S . -- |
6 | -- G E N E R I C _ O P E R A T I O N S -- | |
4c2d6a70 AC |
7 | -- -- |
8 | -- B o d y -- | |
9 | -- -- | |
67ce0d7e | 10 | -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- |
4c2d6a70 | 11 | -- -- |
4c2d6a70 AC |
12 | -- GNAT is free software; you can redistribute it and/or modify it under -- |
13 | -- terms of the GNU General Public License as published by the Free Soft- -- | |
14 | -- ware Foundation; either version 2, or (at your option) any later ver- -- | |
15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- | |
16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- | |
17 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- | |
18 | -- for more details. You should have received a copy of the GNU General -- | |
19 | -- Public License distributed with GNAT; see file COPYING. If not, write -- | |
cb5fee25 KC |
20 | -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- |
21 | -- Boston, MA 02110-1301, USA. -- | |
4c2d6a70 AC |
22 | -- -- |
23 | -- As a special exception, if other files instantiate generics from this -- | |
24 | -- unit, or you link this unit with other files to produce an executable, -- | |
25 | -- this unit does not by itself cause the resulting executable to be -- | |
26 | -- covered by the GNU General Public License. This exception does not -- | |
27 | -- however invalidate any other reasons why the executable file might be -- | |
28 | -- covered by the GNU Public License. -- | |
29 | -- -- | |
30 | -- This unit was originally developed by Matthew J Heaney. -- | |
31 | ------------------------------------------------------------------------------ | |
32 | ||
3837bc7f MH |
33 | -- The references below to "CLR" refer to the following book, from which |
34 | -- several of the algorithms here were adapted: | |
35 | -- Introduction to Algorithms | |
36 | -- by Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest | |
37 | -- Publisher: The MIT Press (June 18, 1990) | |
38 | -- ISBN: 0262031418 | |
39 | ||
8704d4b3 MH |
40 | with System; use type System.Address; |
41 | ||
4c2d6a70 AC |
42 | package body Ada.Containers.Red_Black_Trees.Generic_Operations is |
43 | ||
44 | ----------------------- | |
45 | -- Local Subprograms -- | |
46 | ----------------------- | |
47 | ||
48 | procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access); | |
49 | ||
50 | procedure Delete_Swap (Tree : in out Tree_Type; Z, Y : Node_Access); | |
51 | ||
52 | procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access); | |
53 | procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access); | |
54 | ||
2368f04e MH |
55 | -- --------------------- |
56 | -- -- Check_Invariant -- | |
57 | -- --------------------- | |
58 | ||
59 | -- procedure Check_Invariant (Tree : Tree_Type) is | |
60 | -- Root : constant Node_Access := Tree.Root; | |
61 | -- | |
62 | -- function Check (Node : Node_Access) return Natural; | |
63 | -- | |
64 | -- ----------- | |
65 | -- -- Check -- | |
66 | -- ----------- | |
67 | -- | |
68 | -- function Check (Node : Node_Access) return Natural is | |
69 | -- begin | |
70 | -- if Node = null then | |
71 | -- return 0; | |
72 | -- end if; | |
73 | -- | |
74 | -- if Color (Node) = Red then | |
75 | -- declare | |
76 | -- L : constant Node_Access := Left (Node); | |
77 | -- begin | |
78 | -- pragma Assert (L = null or else Color (L) = Black); | |
79 | -- null; | |
80 | -- end; | |
81 | -- | |
82 | -- declare | |
83 | -- R : constant Node_Access := Right (Node); | |
84 | -- begin | |
85 | -- pragma Assert (R = null or else Color (R) = Black); | |
86 | -- null; | |
87 | -- end; | |
88 | -- | |
89 | -- declare | |
90 | -- NL : constant Natural := Check (Left (Node)); | |
91 | -- NR : constant Natural := Check (Right (Node)); | |
92 | -- begin | |
93 | -- pragma Assert (NL = NR); | |
94 | -- return NL; | |
95 | -- end; | |
96 | -- end if; | |
97 | -- | |
98 | -- declare | |
99 | -- NL : constant Natural := Check (Left (Node)); | |
100 | -- NR : constant Natural := Check (Right (Node)); | |
101 | -- begin | |
102 | -- pragma Assert (NL = NR); | |
103 | -- return NL + 1; | |
104 | -- end; | |
105 | -- end Check; | |
106 | -- | |
107 | -- -- Start of processing for Check_Invariant | |
108 | -- | |
109 | -- begin | |
110 | -- if Root = null then | |
111 | -- pragma Assert (Tree.First = null); | |
112 | -- pragma Assert (Tree.Last = null); | |
113 | -- pragma Assert (Tree.Length = 0); | |
114 | -- null; | |
115 | -- | |
116 | -- else | |
117 | -- pragma Assert (Color (Root) = Black); | |
118 | -- pragma Assert (Tree.Length > 0); | |
119 | -- pragma Assert (Tree.Root /= null); | |
120 | -- pragma Assert (Tree.First /= null); | |
121 | -- pragma Assert (Tree.Last /= null); | |
122 | -- pragma Assert (Parent (Tree.Root) = null); | |
123 | -- pragma Assert ((Tree.Length > 1) | |
124 | -- or else (Tree.First = Tree.Last | |
125 | -- and Tree.First = Tree.Root)); | |
126 | -- pragma Assert (Left (Tree.First) = null); | |
127 | -- pragma Assert (Right (Tree.Last) = null); | |
128 | -- | |
129 | -- declare | |
130 | -- L : constant Node_Access := Left (Root); | |
131 | -- R : constant Node_Access := Right (Root); | |
132 | -- NL : constant Natural := Check (L); | |
133 | -- NR : constant Natural := Check (R); | |
134 | -- begin | |
135 | -- pragma Assert (NL = NR); | |
136 | -- null; | |
137 | -- end; | |
138 | -- end if; | |
139 | -- end Check_Invariant; | |
4c2d6a70 AC |
140 | |
141 | ------------------ | |
142 | -- Delete_Fixup -- | |
143 | ------------------ | |
144 | ||
145 | procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access) is | |
146 | ||
3837bc7f | 147 | -- CLR p274 |
4c2d6a70 AC |
148 | |
149 | X : Node_Access := Node; | |
150 | W : Node_Access; | |
151 | ||
152 | begin | |
153 | while X /= Tree.Root | |
154 | and then Color (X) = Black | |
155 | loop | |
156 | if X = Left (Parent (X)) then | |
157 | W := Right (Parent (X)); | |
158 | ||
159 | if Color (W) = Red then | |
160 | Set_Color (W, Black); | |
161 | Set_Color (Parent (X), Red); | |
162 | Left_Rotate (Tree, Parent (X)); | |
163 | W := Right (Parent (X)); | |
164 | end if; | |
165 | ||
8704d4b3 | 166 | if (Left (W) = null or else Color (Left (W)) = Black) |
4c2d6a70 | 167 | and then |
8704d4b3 | 168 | (Right (W) = null or else Color (Right (W)) = Black) |
4c2d6a70 AC |
169 | then |
170 | Set_Color (W, Red); | |
171 | X := Parent (X); | |
172 | ||
173 | else | |
8704d4b3 | 174 | if Right (W) = null |
4c2d6a70 AC |
175 | or else Color (Right (W)) = Black |
176 | then | |
8704d4b3 | 177 | if Left (W) /= null then |
4c2d6a70 AC |
178 | Set_Color (Left (W), Black); |
179 | end if; | |
180 | ||
181 | Set_Color (W, Red); | |
182 | Right_Rotate (Tree, W); | |
183 | W := Right (Parent (X)); | |
184 | end if; | |
185 | ||
186 | Set_Color (W, Color (Parent (X))); | |
187 | Set_Color (Parent (X), Black); | |
188 | Set_Color (Right (W), Black); | |
189 | Left_Rotate (Tree, Parent (X)); | |
190 | X := Tree.Root; | |
191 | end if; | |
192 | ||
193 | else | |
194 | pragma Assert (X = Right (Parent (X))); | |
195 | ||
196 | W := Left (Parent (X)); | |
197 | ||
198 | if Color (W) = Red then | |
199 | Set_Color (W, Black); | |
200 | Set_Color (Parent (X), Red); | |
201 | Right_Rotate (Tree, Parent (X)); | |
202 | W := Left (Parent (X)); | |
203 | end if; | |
204 | ||
8704d4b3 | 205 | if (Left (W) = null or else Color (Left (W)) = Black) |
4c2d6a70 | 206 | and then |
8704d4b3 | 207 | (Right (W) = null or else Color (Right (W)) = Black) |
4c2d6a70 AC |
208 | then |
209 | Set_Color (W, Red); | |
210 | X := Parent (X); | |
211 | ||
212 | else | |
8704d4b3 MH |
213 | if Left (W) = null or else Color (Left (W)) = Black then |
214 | if Right (W) /= null then | |
4c2d6a70 AC |
215 | Set_Color (Right (W), Black); |
216 | end if; | |
217 | ||
218 | Set_Color (W, Red); | |
219 | Left_Rotate (Tree, W); | |
220 | W := Left (Parent (X)); | |
221 | end if; | |
222 | ||
223 | Set_Color (W, Color (Parent (X))); | |
224 | Set_Color (Parent (X), Black); | |
225 | Set_Color (Left (W), Black); | |
226 | Right_Rotate (Tree, Parent (X)); | |
227 | X := Tree.Root; | |
228 | end if; | |
229 | end if; | |
230 | end loop; | |
231 | ||
232 | Set_Color (X, Black); | |
233 | end Delete_Fixup; | |
234 | ||
235 | --------------------------- | |
236 | -- Delete_Node_Sans_Free -- | |
237 | --------------------------- | |
238 | ||
239 | procedure Delete_Node_Sans_Free | |
240 | (Tree : in out Tree_Type; | |
241 | Node : Node_Access) | |
242 | is | |
3837bc7f | 243 | -- CLR p273 |
4c2d6a70 AC |
244 | |
245 | X, Y : Node_Access; | |
246 | ||
247 | Z : constant Node_Access := Node; | |
8704d4b3 | 248 | pragma Assert (Z /= null); |
4c2d6a70 AC |
249 | |
250 | begin | |
8704d4b3 | 251 | if Tree.Busy > 0 then |
ffabcde5 MH |
252 | raise Program_Error with |
253 | "attempt to tamper with cursors (container is busy)"; | |
8704d4b3 MH |
254 | end if; |
255 | ||
2368f04e MH |
256 | -- pragma Assert (Tree.Length > 0); |
257 | -- pragma Assert (Tree.Root /= null); | |
258 | -- pragma Assert (Tree.First /= null); | |
259 | -- pragma Assert (Tree.Last /= null); | |
260 | -- pragma Assert (Parent (Tree.Root) = null); | |
261 | -- pragma Assert ((Tree.Length > 1) | |
262 | -- or else (Tree.First = Tree.Last | |
263 | -- and then Tree.First = Tree.Root)); | |
264 | -- pragma Assert ((Left (Node) = null) | |
265 | -- or else (Parent (Left (Node)) = Node)); | |
266 | -- pragma Assert ((Right (Node) = null) | |
267 | -- or else (Parent (Right (Node)) = Node)); | |
268 | -- pragma Assert (((Parent (Node) = null) and then (Tree.Root = Node)) | |
269 | -- or else ((Parent (Node) /= null) and then | |
270 | -- ((Left (Parent (Node)) = Node) | |
271 | -- or else (Right (Parent (Node)) = Node)))); | |
4c2d6a70 | 272 | |
8704d4b3 MH |
273 | if Left (Z) = null then |
274 | if Right (Z) = null then | |
4c2d6a70 AC |
275 | if Z = Tree.First then |
276 | Tree.First := Parent (Z); | |
277 | end if; | |
278 | ||
279 | if Z = Tree.Last then | |
280 | Tree.Last := Parent (Z); | |
281 | end if; | |
282 | ||
283 | if Color (Z) = Black then | |
284 | Delete_Fixup (Tree, Z); | |
285 | end if; | |
286 | ||
8704d4b3 MH |
287 | pragma Assert (Left (Z) = null); |
288 | pragma Assert (Right (Z) = null); | |
4c2d6a70 AC |
289 | |
290 | if Z = Tree.Root then | |
291 | pragma Assert (Tree.Length = 1); | |
8704d4b3 MH |
292 | pragma Assert (Parent (Z) = null); |
293 | Tree.Root := null; | |
4c2d6a70 | 294 | elsif Z = Left (Parent (Z)) then |
8704d4b3 | 295 | Set_Left (Parent (Z), null); |
4c2d6a70 AC |
296 | else |
297 | pragma Assert (Z = Right (Parent (Z))); | |
8704d4b3 | 298 | Set_Right (Parent (Z), null); |
4c2d6a70 AC |
299 | end if; |
300 | ||
301 | else | |
302 | pragma Assert (Z /= Tree.Last); | |
303 | ||
304 | X := Right (Z); | |
305 | ||
306 | if Z = Tree.First then | |
307 | Tree.First := Min (X); | |
308 | end if; | |
309 | ||
310 | if Z = Tree.Root then | |
311 | Tree.Root := X; | |
312 | elsif Z = Left (Parent (Z)) then | |
313 | Set_Left (Parent (Z), X); | |
314 | else | |
315 | pragma Assert (Z = Right (Parent (Z))); | |
316 | Set_Right (Parent (Z), X); | |
317 | end if; | |
318 | ||
319 | Set_Parent (X, Parent (Z)); | |
320 | ||
321 | if Color (Z) = Black then | |
322 | Delete_Fixup (Tree, X); | |
323 | end if; | |
324 | end if; | |
325 | ||
8704d4b3 | 326 | elsif Right (Z) = null then |
4c2d6a70 AC |
327 | pragma Assert (Z /= Tree.First); |
328 | ||
329 | X := Left (Z); | |
330 | ||
331 | if Z = Tree.Last then | |
332 | Tree.Last := Max (X); | |
333 | end if; | |
334 | ||
335 | if Z = Tree.Root then | |
336 | Tree.Root := X; | |
337 | elsif Z = Left (Parent (Z)) then | |
338 | Set_Left (Parent (Z), X); | |
339 | else | |
340 | pragma Assert (Z = Right (Parent (Z))); | |
341 | Set_Right (Parent (Z), X); | |
342 | end if; | |
343 | ||
344 | Set_Parent (X, Parent (Z)); | |
345 | ||
346 | if Color (Z) = Black then | |
347 | Delete_Fixup (Tree, X); | |
348 | end if; | |
349 | ||
350 | else | |
351 | pragma Assert (Z /= Tree.First); | |
352 | pragma Assert (Z /= Tree.Last); | |
353 | ||
354 | Y := Next (Z); | |
8704d4b3 | 355 | pragma Assert (Left (Y) = null); |
4c2d6a70 AC |
356 | |
357 | X := Right (Y); | |
358 | ||
8704d4b3 | 359 | if X = null then |
4c2d6a70 AC |
360 | if Y = Left (Parent (Y)) then |
361 | pragma Assert (Parent (Y) /= Z); | |
362 | Delete_Swap (Tree, Z, Y); | |
363 | Set_Left (Parent (Z), Z); | |
364 | ||
365 | else | |
366 | pragma Assert (Y = Right (Parent (Y))); | |
367 | pragma Assert (Parent (Y) = Z); | |
368 | Set_Parent (Y, Parent (Z)); | |
369 | ||
370 | if Z = Tree.Root then | |
371 | Tree.Root := Y; | |
372 | elsif Z = Left (Parent (Z)) then | |
373 | Set_Left (Parent (Z), Y); | |
374 | else | |
375 | pragma Assert (Z = Right (Parent (Z))); | |
376 | Set_Right (Parent (Z), Y); | |
377 | end if; | |
378 | ||
379 | Set_Left (Y, Left (Z)); | |
380 | Set_Parent (Left (Y), Y); | |
381 | Set_Right (Y, Z); | |
382 | Set_Parent (Z, Y); | |
8704d4b3 MH |
383 | Set_Left (Z, null); |
384 | Set_Right (Z, null); | |
4c2d6a70 AC |
385 | |
386 | declare | |
387 | Y_Color : constant Color_Type := Color (Y); | |
388 | begin | |
389 | Set_Color (Y, Color (Z)); | |
390 | Set_Color (Z, Y_Color); | |
391 | end; | |
392 | end if; | |
393 | ||
394 | if Color (Z) = Black then | |
395 | Delete_Fixup (Tree, Z); | |
396 | end if; | |
397 | ||
8704d4b3 MH |
398 | pragma Assert (Left (Z) = null); |
399 | pragma Assert (Right (Z) = null); | |
4c2d6a70 AC |
400 | |
401 | if Z = Right (Parent (Z)) then | |
8704d4b3 | 402 | Set_Right (Parent (Z), null); |
4c2d6a70 AC |
403 | else |
404 | pragma Assert (Z = Left (Parent (Z))); | |
8704d4b3 | 405 | Set_Left (Parent (Z), null); |
4c2d6a70 AC |
406 | end if; |
407 | ||
408 | else | |
409 | if Y = Left (Parent (Y)) then | |
410 | pragma Assert (Parent (Y) /= Z); | |
411 | ||
412 | Delete_Swap (Tree, Z, Y); | |
413 | ||
414 | Set_Left (Parent (Z), X); | |
415 | Set_Parent (X, Parent (Z)); | |
416 | ||
417 | else | |
418 | pragma Assert (Y = Right (Parent (Y))); | |
419 | pragma Assert (Parent (Y) = Z); | |
420 | ||
421 | Set_Parent (Y, Parent (Z)); | |
422 | ||
423 | if Z = Tree.Root then | |
424 | Tree.Root := Y; | |
425 | elsif Z = Left (Parent (Z)) then | |
426 | Set_Left (Parent (Z), Y); | |
427 | else | |
428 | pragma Assert (Z = Right (Parent (Z))); | |
429 | Set_Right (Parent (Z), Y); | |
430 | end if; | |
431 | ||
432 | Set_Left (Y, Left (Z)); | |
433 | Set_Parent (Left (Y), Y); | |
434 | ||
435 | declare | |
436 | Y_Color : constant Color_Type := Color (Y); | |
437 | begin | |
438 | Set_Color (Y, Color (Z)); | |
439 | Set_Color (Z, Y_Color); | |
440 | end; | |
441 | end if; | |
442 | ||
443 | if Color (Z) = Black then | |
444 | Delete_Fixup (Tree, X); | |
445 | end if; | |
446 | end if; | |
447 | end if; | |
448 | ||
449 | Tree.Length := Tree.Length - 1; | |
450 | end Delete_Node_Sans_Free; | |
451 | ||
452 | ----------------- | |
453 | -- Delete_Swap -- | |
454 | ----------------- | |
455 | ||
456 | procedure Delete_Swap | |
457 | (Tree : in out Tree_Type; | |
458 | Z, Y : Node_Access) | |
459 | is | |
460 | pragma Assert (Z /= Y); | |
461 | pragma Assert (Parent (Y) /= Z); | |
462 | ||
463 | Y_Parent : constant Node_Access := Parent (Y); | |
464 | Y_Color : constant Color_Type := Color (Y); | |
465 | ||
466 | begin | |
467 | Set_Parent (Y, Parent (Z)); | |
468 | Set_Left (Y, Left (Z)); | |
469 | Set_Right (Y, Right (Z)); | |
470 | Set_Color (Y, Color (Z)); | |
471 | ||
472 | if Tree.Root = Z then | |
473 | Tree.Root := Y; | |
474 | elsif Right (Parent (Y)) = Z then | |
475 | Set_Right (Parent (Y), Y); | |
476 | else | |
477 | pragma Assert (Left (Parent (Y)) = Z); | |
478 | Set_Left (Parent (Y), Y); | |
479 | end if; | |
480 | ||
8704d4b3 | 481 | if Right (Y) /= null then |
4c2d6a70 AC |
482 | Set_Parent (Right (Y), Y); |
483 | end if; | |
484 | ||
8704d4b3 | 485 | if Left (Y) /= null then |
4c2d6a70 AC |
486 | Set_Parent (Left (Y), Y); |
487 | end if; | |
488 | ||
489 | Set_Parent (Z, Y_Parent); | |
490 | Set_Color (Z, Y_Color); | |
8704d4b3 MH |
491 | Set_Left (Z, null); |
492 | Set_Right (Z, null); | |
4c2d6a70 AC |
493 | end Delete_Swap; |
494 | ||
8704d4b3 MH |
495 | -------------------- |
496 | -- Generic_Adjust -- | |
497 | -------------------- | |
498 | ||
499 | procedure Generic_Adjust (Tree : in out Tree_Type) is | |
500 | N : constant Count_Type := Tree.Length; | |
501 | Root : constant Node_Access := Tree.Root; | |
502 | ||
503 | begin | |
504 | if N = 0 then | |
505 | pragma Assert (Root = null); | |
506 | pragma Assert (Tree.Busy = 0); | |
507 | pragma Assert (Tree.Lock = 0); | |
508 | return; | |
509 | end if; | |
510 | ||
511 | Tree.Root := null; | |
512 | Tree.First := null; | |
513 | Tree.Last := null; | |
514 | Tree.Length := 0; | |
515 | ||
516 | Tree.Root := Copy_Tree (Root); | |
517 | Tree.First := Min (Tree.Root); | |
518 | Tree.Last := Max (Tree.Root); | |
519 | Tree.Length := N; | |
520 | end Generic_Adjust; | |
521 | ||
522 | ------------------- | |
523 | -- Generic_Clear -- | |
524 | ------------------- | |
525 | ||
526 | procedure Generic_Clear (Tree : in out Tree_Type) is | |
527 | Root : Node_Access := Tree.Root; | |
528 | begin | |
529 | if Tree.Busy > 0 then | |
ffabcde5 MH |
530 | raise Program_Error with |
531 | "attempt to tamper with cursors (container is busy)"; | |
8704d4b3 MH |
532 | end if; |
533 | ||
534 | Tree := (First => null, | |
535 | Last => null, | |
536 | Root => null, | |
537 | Length => 0, | |
538 | Busy => 0, | |
539 | Lock => 0); | |
540 | ||
541 | Delete_Tree (Root); | |
542 | end Generic_Clear; | |
543 | ||
544 | ----------------------- | |
545 | -- Generic_Copy_Tree -- | |
546 | ----------------------- | |
547 | ||
548 | function Generic_Copy_Tree (Source_Root : Node_Access) return Node_Access is | |
549 | Target_Root : Node_Access := Copy_Node (Source_Root); | |
550 | P, X : Node_Access; | |
551 | ||
552 | begin | |
8704d4b3 MH |
553 | if Right (Source_Root) /= null then |
554 | Set_Right | |
555 | (Node => Target_Root, | |
556 | Right => Generic_Copy_Tree (Right (Source_Root))); | |
557 | ||
558 | Set_Parent | |
559 | (Node => Right (Target_Root), | |
560 | Parent => Target_Root); | |
561 | end if; | |
562 | ||
563 | P := Target_Root; | |
564 | ||
565 | X := Left (Source_Root); | |
566 | while X /= null loop | |
567 | declare | |
568 | Y : constant Node_Access := Copy_Node (X); | |
569 | begin | |
570 | Set_Left (Node => P, Left => Y); | |
571 | Set_Parent (Node => Y, Parent => P); | |
572 | ||
573 | if Right (X) /= null then | |
574 | Set_Right | |
575 | (Node => Y, | |
576 | Right => Generic_Copy_Tree (Right (X))); | |
577 | ||
578 | Set_Parent | |
579 | (Node => Right (Y), | |
580 | Parent => Y); | |
581 | end if; | |
582 | ||
583 | P := Y; | |
584 | X := Left (X); | |
585 | end; | |
586 | end loop; | |
587 | ||
588 | return Target_Root; | |
589 | exception | |
590 | when others => | |
591 | Delete_Tree (Target_Root); | |
592 | raise; | |
8704d4b3 MH |
593 | end Generic_Copy_Tree; |
594 | ||
595 | ------------------------- | |
596 | -- Generic_Delete_Tree -- | |
597 | ------------------------- | |
598 | ||
599 | procedure Generic_Delete_Tree (X : in out Node_Access) is | |
600 | Y : Node_Access; | |
67ce0d7e | 601 | pragma Warnings (Off, Y); |
8704d4b3 MH |
602 | begin |
603 | while X /= null loop | |
604 | Y := Right (X); | |
605 | Generic_Delete_Tree (Y); | |
606 | Y := Left (X); | |
607 | Free (X); | |
608 | X := Y; | |
609 | end loop; | |
610 | end Generic_Delete_Tree; | |
611 | ||
4c2d6a70 AC |
612 | ------------------- |
613 | -- Generic_Equal -- | |
614 | ------------------- | |
615 | ||
616 | function Generic_Equal (Left, Right : Tree_Type) return Boolean is | |
617 | L_Node : Node_Access; | |
618 | R_Node : Node_Access; | |
619 | ||
620 | begin | |
8704d4b3 MH |
621 | if Left'Address = Right'Address then |
622 | return True; | |
623 | end if; | |
624 | ||
4c2d6a70 AC |
625 | if Left.Length /= Right.Length then |
626 | return False; | |
627 | end if; | |
628 | ||
629 | L_Node := Left.First; | |
630 | R_Node := Right.First; | |
8704d4b3 | 631 | while L_Node /= null loop |
4c2d6a70 AC |
632 | if not Is_Equal (L_Node, R_Node) then |
633 | return False; | |
634 | end if; | |
635 | ||
636 | L_Node := Next (L_Node); | |
637 | R_Node := Next (R_Node); | |
638 | end loop; | |
639 | ||
640 | return True; | |
641 | end Generic_Equal; | |
642 | ||
643 | ----------------------- | |
644 | -- Generic_Iteration -- | |
645 | ----------------------- | |
646 | ||
647 | procedure Generic_Iteration (Tree : Tree_Type) is | |
648 | procedure Iterate (P : Node_Access); | |
649 | ||
650 | ------------- | |
651 | -- Iterate -- | |
652 | ------------- | |
653 | ||
654 | procedure Iterate (P : Node_Access) is | |
655 | X : Node_Access := P; | |
656 | begin | |
8704d4b3 | 657 | while X /= null loop |
4c2d6a70 AC |
658 | Iterate (Left (X)); |
659 | Process (X); | |
660 | X := Right (X); | |
661 | end loop; | |
662 | end Iterate; | |
663 | ||
664 | -- Start of processing for Generic_Iteration | |
665 | ||
666 | begin | |
667 | Iterate (Tree.Root); | |
668 | end Generic_Iteration; | |
669 | ||
670 | ------------------ | |
8704d4b3 | 671 | -- Generic_Move -- |
4c2d6a70 AC |
672 | ------------------ |
673 | ||
8704d4b3 MH |
674 | procedure Generic_Move (Target, Source : in out Tree_Type) is |
675 | begin | |
676 | if Target'Address = Source'Address then | |
677 | return; | |
678 | end if; | |
4c2d6a70 | 679 | |
8704d4b3 | 680 | if Source.Busy > 0 then |
ffabcde5 MH |
681 | raise Program_Error with |
682 | "attempt to tamper with cursors (container is busy)"; | |
8704d4b3 MH |
683 | end if; |
684 | ||
685 | Clear (Target); | |
686 | ||
687 | Target := Source; | |
688 | ||
689 | Source := (First => null, | |
690 | Last => null, | |
691 | Root => null, | |
692 | Length => 0, | |
693 | Busy => 0, | |
694 | Lock => 0); | |
695 | end Generic_Move; | |
696 | ||
697 | ------------------ | |
698 | -- Generic_Read -- | |
699 | ------------------ | |
700 | ||
701 | procedure Generic_Read | |
d90e94c7 | 702 | (Stream : not null access Root_Stream_Type'Class; |
8704d4b3 MH |
703 | Tree : in out Tree_Type) |
704 | is | |
705 | N : Count_Type'Base; | |
4c2d6a70 AC |
706 | |
707 | Node, Last_Node : Node_Access; | |
708 | ||
709 | begin | |
8704d4b3 MH |
710 | Clear (Tree); |
711 | ||
712 | Count_Type'Base'Read (Stream, N); | |
713 | pragma Assert (N >= 0); | |
714 | ||
4c2d6a70 AC |
715 | if N = 0 then |
716 | return; | |
717 | end if; | |
718 | ||
8704d4b3 MH |
719 | Node := Read_Node (Stream); |
720 | pragma Assert (Node /= null); | |
4c2d6a70 AC |
721 | pragma Assert (Color (Node) = Red); |
722 | ||
723 | Set_Color (Node, Black); | |
724 | ||
725 | Tree.Root := Node; | |
726 | Tree.First := Node; | |
727 | Tree.Last := Node; | |
728 | ||
729 | Tree.Length := 1; | |
730 | ||
731 | for J in Count_Type range 2 .. N loop | |
732 | Last_Node := Node; | |
733 | pragma Assert (Last_Node = Tree.Last); | |
734 | ||
8704d4b3 MH |
735 | Node := Read_Node (Stream); |
736 | pragma Assert (Node /= null); | |
4c2d6a70 AC |
737 | pragma Assert (Color (Node) = Red); |
738 | ||
739 | Set_Right (Node => Last_Node, Right => Node); | |
740 | Tree.Last := Node; | |
741 | Set_Parent (Node => Node, Parent => Last_Node); | |
742 | Rebalance_For_Insert (Tree, Node); | |
743 | Tree.Length := Tree.Length + 1; | |
744 | end loop; | |
745 | end Generic_Read; | |
746 | ||
747 | ------------------------------- | |
748 | -- Generic_Reverse_Iteration -- | |
749 | ------------------------------- | |
750 | ||
751 | procedure Generic_Reverse_Iteration (Tree : Tree_Type) | |
752 | is | |
753 | procedure Iterate (P : Node_Access); | |
754 | ||
755 | ------------- | |
756 | -- Iterate -- | |
757 | ------------- | |
758 | ||
759 | procedure Iterate (P : Node_Access) is | |
760 | X : Node_Access := P; | |
761 | begin | |
8704d4b3 | 762 | while X /= null loop |
4c2d6a70 AC |
763 | Iterate (Right (X)); |
764 | Process (X); | |
765 | X := Left (X); | |
766 | end loop; | |
767 | end Iterate; | |
768 | ||
769 | -- Start of processing for Generic_Reverse_Iteration | |
770 | ||
771 | begin | |
772 | Iterate (Tree.Root); | |
773 | end Generic_Reverse_Iteration; | |
774 | ||
8704d4b3 MH |
775 | ------------------- |
776 | -- Generic_Write -- | |
777 | ------------------- | |
778 | ||
779 | procedure Generic_Write | |
d90e94c7 | 780 | (Stream : not null access Root_Stream_Type'Class; |
ffabcde5 | 781 | Tree : Tree_Type) |
8704d4b3 MH |
782 | is |
783 | procedure Process (Node : Node_Access); | |
784 | pragma Inline (Process); | |
785 | ||
786 | procedure Iterate is | |
787 | new Generic_Iteration (Process); | |
788 | ||
789 | ------------- | |
790 | -- Process -- | |
791 | ------------- | |
792 | ||
793 | procedure Process (Node : Node_Access) is | |
794 | begin | |
795 | Write_Node (Stream, Node); | |
796 | end Process; | |
797 | ||
798 | -- Start of processing for Generic_Write | |
799 | ||
800 | begin | |
801 | Count_Type'Base'Write (Stream, Tree.Length); | |
802 | Iterate (Tree); | |
803 | end Generic_Write; | |
804 | ||
4c2d6a70 AC |
805 | ----------------- |
806 | -- Left_Rotate -- | |
807 | ----------------- | |
808 | ||
809 | procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access) is | |
810 | ||
3837bc7f | 811 | -- CLR p266 |
4c2d6a70 AC |
812 | |
813 | Y : constant Node_Access := Right (X); | |
8704d4b3 | 814 | pragma Assert (Y /= null); |
4c2d6a70 AC |
815 | |
816 | begin | |
817 | Set_Right (X, Left (Y)); | |
818 | ||
8704d4b3 | 819 | if Left (Y) /= null then |
4c2d6a70 AC |
820 | Set_Parent (Left (Y), X); |
821 | end if; | |
822 | ||
823 | Set_Parent (Y, Parent (X)); | |
824 | ||
825 | if X = Tree.Root then | |
826 | Tree.Root := Y; | |
827 | elsif X = Left (Parent (X)) then | |
828 | Set_Left (Parent (X), Y); | |
829 | else | |
830 | pragma Assert (X = Right (Parent (X))); | |
831 | Set_Right (Parent (X), Y); | |
832 | end if; | |
833 | ||
834 | Set_Left (Y, X); | |
835 | Set_Parent (X, Y); | |
836 | end Left_Rotate; | |
837 | ||
838 | --------- | |
839 | -- Max -- | |
840 | --------- | |
841 | ||
842 | function Max (Node : Node_Access) return Node_Access is | |
843 | ||
3837bc7f | 844 | -- CLR p248 |
4c2d6a70 AC |
845 | |
846 | X : Node_Access := Node; | |
847 | Y : Node_Access; | |
848 | ||
849 | begin | |
850 | loop | |
851 | Y := Right (X); | |
852 | ||
8704d4b3 | 853 | if Y = null then |
4c2d6a70 AC |
854 | return X; |
855 | end if; | |
856 | ||
857 | X := Y; | |
858 | end loop; | |
859 | end Max; | |
860 | ||
861 | --------- | |
862 | -- Min -- | |
863 | --------- | |
864 | ||
865 | function Min (Node : Node_Access) return Node_Access is | |
866 | ||
3837bc7f | 867 | -- CLR p248 |
4c2d6a70 AC |
868 | |
869 | X : Node_Access := Node; | |
870 | Y : Node_Access; | |
871 | ||
872 | begin | |
873 | loop | |
874 | Y := Left (X); | |
875 | ||
8704d4b3 | 876 | if Y = null then |
4c2d6a70 AC |
877 | return X; |
878 | end if; | |
879 | ||
880 | X := Y; | |
881 | end loop; | |
882 | end Min; | |
883 | ||
4c2d6a70 AC |
884 | ---------- |
885 | -- Next -- | |
886 | ---------- | |
887 | ||
888 | function Next (Node : Node_Access) return Node_Access is | |
889 | begin | |
3837bc7f | 890 | -- CLR p249 |
4c2d6a70 | 891 | |
8704d4b3 MH |
892 | if Node = null then |
893 | return null; | |
4c2d6a70 AC |
894 | end if; |
895 | ||
8704d4b3 | 896 | if Right (Node) /= null then |
4c2d6a70 AC |
897 | return Min (Right (Node)); |
898 | end if; | |
899 | ||
900 | declare | |
901 | X : Node_Access := Node; | |
902 | Y : Node_Access := Parent (Node); | |
903 | ||
904 | begin | |
8704d4b3 | 905 | while Y /= null |
4c2d6a70 AC |
906 | and then X = Right (Y) |
907 | loop | |
908 | X := Y; | |
909 | Y := Parent (Y); | |
910 | end loop; | |
911 | ||
4c2d6a70 AC |
912 | return Y; |
913 | end; | |
914 | end Next; | |
915 | ||
916 | -------------- | |
917 | -- Previous -- | |
918 | -------------- | |
919 | ||
920 | function Previous (Node : Node_Access) return Node_Access is | |
921 | begin | |
8704d4b3 MH |
922 | if Node = null then |
923 | return null; | |
4c2d6a70 AC |
924 | end if; |
925 | ||
8704d4b3 | 926 | if Left (Node) /= null then |
4c2d6a70 AC |
927 | return Max (Left (Node)); |
928 | end if; | |
929 | ||
930 | declare | |
931 | X : Node_Access := Node; | |
932 | Y : Node_Access := Parent (Node); | |
933 | ||
934 | begin | |
8704d4b3 | 935 | while Y /= null |
4c2d6a70 AC |
936 | and then X = Left (Y) |
937 | loop | |
938 | X := Y; | |
939 | Y := Parent (Y); | |
940 | end loop; | |
941 | ||
4c2d6a70 AC |
942 | return Y; |
943 | end; | |
944 | end Previous; | |
945 | ||
946 | -------------------------- | |
947 | -- Rebalance_For_Insert -- | |
948 | -------------------------- | |
949 | ||
950 | procedure Rebalance_For_Insert | |
951 | (Tree : in out Tree_Type; | |
952 | Node : Node_Access) | |
953 | is | |
3837bc7f | 954 | -- CLR p.268 |
4c2d6a70 AC |
955 | |
956 | X : Node_Access := Node; | |
8704d4b3 | 957 | pragma Assert (X /= null); |
4c2d6a70 AC |
958 | pragma Assert (Color (X) = Red); |
959 | ||
960 | Y : Node_Access; | |
961 | ||
962 | begin | |
963 | while X /= Tree.Root and then Color (Parent (X)) = Red loop | |
964 | if Parent (X) = Left (Parent (Parent (X))) then | |
965 | Y := Right (Parent (Parent (X))); | |
966 | ||
8704d4b3 | 967 | if Y /= null and then Color (Y) = Red then |
4c2d6a70 AC |
968 | Set_Color (Parent (X), Black); |
969 | Set_Color (Y, Black); | |
970 | Set_Color (Parent (Parent (X)), Red); | |
971 | X := Parent (Parent (X)); | |
972 | ||
973 | else | |
974 | if X = Right (Parent (X)) then | |
975 | X := Parent (X); | |
976 | Left_Rotate (Tree, X); | |
977 | end if; | |
978 | ||
979 | Set_Color (Parent (X), Black); | |
980 | Set_Color (Parent (Parent (X)), Red); | |
981 | Right_Rotate (Tree, Parent (Parent (X))); | |
982 | end if; | |
983 | ||
984 | else | |
985 | pragma Assert (Parent (X) = Right (Parent (Parent (X)))); | |
986 | ||
987 | Y := Left (Parent (Parent (X))); | |
988 | ||
8704d4b3 | 989 | if Y /= null and then Color (Y) = Red then |
4c2d6a70 AC |
990 | Set_Color (Parent (X), Black); |
991 | Set_Color (Y, Black); | |
992 | Set_Color (Parent (Parent (X)), Red); | |
993 | X := Parent (Parent (X)); | |
994 | ||
995 | else | |
996 | if X = Left (Parent (X)) then | |
997 | X := Parent (X); | |
998 | Right_Rotate (Tree, X); | |
999 | end if; | |
1000 | ||
1001 | Set_Color (Parent (X), Black); | |
1002 | Set_Color (Parent (Parent (X)), Red); | |
1003 | Left_Rotate (Tree, Parent (Parent (X))); | |
1004 | end if; | |
1005 | end if; | |
1006 | end loop; | |
1007 | ||
1008 | Set_Color (Tree.Root, Black); | |
1009 | end Rebalance_For_Insert; | |
1010 | ||
1011 | ------------------ | |
1012 | -- Right_Rotate -- | |
1013 | ------------------ | |
1014 | ||
1015 | procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access) is | |
1016 | X : constant Node_Access := Left (Y); | |
8704d4b3 | 1017 | pragma Assert (X /= null); |
4c2d6a70 AC |
1018 | |
1019 | begin | |
1020 | Set_Left (Y, Right (X)); | |
1021 | ||
8704d4b3 | 1022 | if Right (X) /= null then |
4c2d6a70 AC |
1023 | Set_Parent (Right (X), Y); |
1024 | end if; | |
1025 | ||
1026 | Set_Parent (X, Parent (Y)); | |
1027 | ||
1028 | if Y = Tree.Root then | |
1029 | Tree.Root := X; | |
1030 | elsif Y = Left (Parent (Y)) then | |
1031 | Set_Left (Parent (Y), X); | |
1032 | else | |
1033 | pragma Assert (Y = Right (Parent (Y))); | |
1034 | Set_Right (Parent (Y), X); | |
1035 | end if; | |
1036 | ||
1037 | Set_Right (X, Y); | |
1038 | Set_Parent (Y, X); | |
1039 | end Right_Rotate; | |
1040 | ||
2368f04e MH |
1041 | --------- |
1042 | -- Vet -- | |
1043 | --------- | |
1044 | ||
1045 | function Vet (Tree : Tree_Type; Node : Node_Access) return Boolean is | |
1046 | begin | |
1047 | if Node = null then | |
1048 | return True; | |
1049 | end if; | |
1050 | ||
1051 | if Parent (Node) = Node | |
1052 | or else Left (Node) = Node | |
1053 | or else Right (Node) = Node | |
1054 | then | |
1055 | return False; | |
1056 | end if; | |
1057 | ||
1058 | if Tree.Length = 0 | |
1059 | or else Tree.Root = null | |
1060 | or else Tree.First = null | |
1061 | or else Tree.Last = null | |
1062 | then | |
1063 | return False; | |
1064 | end if; | |
1065 | ||
1066 | if Parent (Tree.Root) /= null then | |
1067 | return False; | |
1068 | end if; | |
1069 | ||
1070 | if Left (Tree.First) /= null then | |
1071 | return False; | |
1072 | end if; | |
1073 | ||
1074 | if Right (Tree.Last) /= null then | |
1075 | return False; | |
1076 | end if; | |
1077 | ||
1078 | if Tree.Length = 1 then | |
1079 | if Tree.First /= Tree.Last | |
1080 | or else Tree.First /= Tree.Root | |
1081 | then | |
1082 | return False; | |
1083 | end if; | |
1084 | ||
1085 | if Node /= Tree.First then | |
1086 | return False; | |
1087 | end if; | |
1088 | ||
1089 | if Parent (Node) /= null | |
1090 | or else Left (Node) /= null | |
1091 | or else Right (Node) /= null | |
1092 | then | |
1093 | return False; | |
1094 | end if; | |
1095 | ||
1096 | return True; | |
1097 | end if; | |
1098 | ||
1099 | if Tree.First = Tree.Last then | |
1100 | return False; | |
1101 | end if; | |
1102 | ||
1103 | if Tree.Length = 2 then | |
1104 | if Tree.First /= Tree.Root | |
1105 | and then Tree.Last /= Tree.Root | |
1106 | then | |
1107 | return False; | |
1108 | end if; | |
1109 | ||
1110 | if Tree.First /= Node | |
1111 | and then Tree.Last /= Node | |
1112 | then | |
1113 | return False; | |
1114 | end if; | |
1115 | end if; | |
1116 | ||
1117 | if Left (Node) /= null | |
1118 | and then Parent (Left (Node)) /= Node | |
1119 | then | |
1120 | return False; | |
1121 | end if; | |
1122 | ||
1123 | if Right (Node) /= null | |
1124 | and then Parent (Right (Node)) /= Node | |
1125 | then | |
1126 | return False; | |
1127 | end if; | |
1128 | ||
1129 | if Parent (Node) = null then | |
1130 | if Tree.Root /= Node then | |
1131 | return False; | |
1132 | end if; | |
1133 | ||
1134 | elsif Left (Parent (Node)) /= Node | |
1135 | and then Right (Parent (Node)) /= Node | |
1136 | then | |
1137 | return False; | |
1138 | end if; | |
1139 | ||
1140 | return True; | |
1141 | end Vet; | |
1142 | ||
4c2d6a70 | 1143 | end Ada.Containers.Red_Black_Trees.Generic_Operations; |