File : a-rbtgbo.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT LIBRARY COMPONENTS --
4 -- --
5 -- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_OPERATIONS --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2004-2016, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
29
30 -- The references in this file to "CLR" refer to the following book, from
31 -- which several of the algorithms here were adapted:
32
33 -- Introduction to Algorithms
34 -- by Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest
35 -- Publisher: The MIT Press (June 18, 1990)
36 -- ISBN: 0262031418
37
38 with System; use type System.Address;
39
40 package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is
41
42 pragma Warnings (Off, "variable ""Busy*"" is not referenced");
43 pragma Warnings (Off, "variable ""Lock*"" is not referenced");
44 -- See comment in Ada.Containers.Helpers
45
46 -----------------------
47 -- Local Subprograms --
48 -----------------------
49
50 procedure Delete_Fixup (Tree : in out Tree_Type'Class; Node : Count_Type);
51 procedure Delete_Swap (Tree : in out Tree_Type'Class; Z, Y : Count_Type);
52
53 procedure Left_Rotate (Tree : in out Tree_Type'Class; X : Count_Type);
54 procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type);
55
56 ----------------
57 -- Clear_Tree --
58 ----------------
59
60 procedure Clear_Tree (Tree : in out Tree_Type'Class) is
61 begin
62 TC_Check (Tree.TC);
63
64 Tree.First := 0;
65 Tree.Last := 0;
66 Tree.Root := 0;
67 Tree.Length := 0;
68 Tree.Free := -1;
69 end Clear_Tree;
70
71 ------------------
72 -- Delete_Fixup --
73 ------------------
74
75 procedure Delete_Fixup
76 (Tree : in out Tree_Type'Class;
77 Node : Count_Type)
78 is
79 -- CLR p. 274
80
81 X : Count_Type;
82 W : Count_Type;
83 N : Nodes_Type renames Tree.Nodes;
84
85 begin
86 X := Node;
87 while X /= Tree.Root and then Color (N (X)) = Black loop
88 if X = Left (N (Parent (N (X)))) then
89 W := Right (N (Parent (N (X))));
90
91 if Color (N (W)) = Red then
92 Set_Color (N (W), Black);
93 Set_Color (N (Parent (N (X))), Red);
94 Left_Rotate (Tree, Parent (N (X)));
95 W := Right (N (Parent (N (X))));
96 end if;
97
98 if (Left (N (W)) = 0 or else Color (N (Left (N (W)))) = Black)
99 and then
100 (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black)
101 then
102 Set_Color (N (W), Red);
103 X := Parent (N (X));
104
105 else
106 if Right (N (W)) = 0
107 or else Color (N (Right (N (W)))) = Black
108 then
109 -- As a condition for setting the color of the left child to
110 -- black, the left child access value must be non-null. A
111 -- truth table analysis shows that if we arrive here, that
112 -- condition holds, so there's no need for an explicit test.
113 -- The assertion is here to document what we know is true.
114
115 pragma Assert (Left (N (W)) /= 0);
116 Set_Color (N (Left (N (W))), Black);
117
118 Set_Color (N (W), Red);
119 Right_Rotate (Tree, W);
120 W := Right (N (Parent (N (X))));
121 end if;
122
123 Set_Color (N (W), Color (N (Parent (N (X)))));
124 Set_Color (N (Parent (N (X))), Black);
125 Set_Color (N (Right (N (W))), Black);
126 Left_Rotate (Tree, Parent (N (X)));
127 X := Tree.Root;
128 end if;
129
130 else
131 pragma Assert (X = Right (N (Parent (N (X)))));
132
133 W := Left (N (Parent (N (X))));
134
135 if Color (N (W)) = Red then
136 Set_Color (N (W), Black);
137 Set_Color (N (Parent (N (X))), Red);
138 Right_Rotate (Tree, Parent (N (X)));
139 W := Left (N (Parent (N (X))));
140 end if;
141
142 if (Left (N (W)) = 0 or else Color (N (Left (N (W)))) = Black)
143 and then
144 (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black)
145 then
146 Set_Color (N (W), Red);
147 X := Parent (N (X));
148
149 else
150 if Left (N (W)) = 0
151 or else Color (N (Left (N (W)))) = Black
152 then
153 -- As a condition for setting the color of the right child
154 -- to black, the right child access value must be non-null.
155 -- A truth table analysis shows that if we arrive here, that
156 -- condition holds, so there's no need for an explicit test.
157 -- The assertion is here to document what we know is true.
158
159 pragma Assert (Right (N (W)) /= 0);
160 Set_Color (N (Right (N (W))), Black);
161
162 Set_Color (N (W), Red);
163 Left_Rotate (Tree, W);
164 W := Left (N (Parent (N (X))));
165 end if;
166
167 Set_Color (N (W), Color (N (Parent (N (X)))));
168 Set_Color (N (Parent (N (X))), Black);
169 Set_Color (N (Left (N (W))), Black);
170 Right_Rotate (Tree, Parent (N (X)));
171 X := Tree.Root;
172 end if;
173 end if;
174 end loop;
175
176 Set_Color (N (X), Black);
177 end Delete_Fixup;
178
179 ---------------------------
180 -- Delete_Node_Sans_Free --
181 ---------------------------
182
183 procedure Delete_Node_Sans_Free
184 (Tree : in out Tree_Type'Class;
185 Node : Count_Type)
186 is
187 -- CLR p. 273
188
189 X, Y : Count_Type;
190
191 Z : constant Count_Type := Node;
192
193 N : Nodes_Type renames Tree.Nodes;
194
195 begin
196 TC_Check (Tree.TC);
197
198 -- If node is not present, return (exception will be raised in caller)
199
200 if Z = 0 then
201 return;
202 end if;
203
204 pragma Assert (Tree.Length > 0);
205 pragma Assert (Tree.Root /= 0);
206 pragma Assert (Tree.First /= 0);
207 pragma Assert (Tree.Last /= 0);
208 pragma Assert (Parent (N (Tree.Root)) = 0);
209
210 pragma Assert ((Tree.Length > 1)
211 or else (Tree.First = Tree.Last
212 and then Tree.First = Tree.Root));
213
214 pragma Assert ((Left (N (Node)) = 0)
215 or else (Parent (N (Left (N (Node)))) = Node));
216
217 pragma Assert ((Right (N (Node)) = 0)
218 or else (Parent (N (Right (N (Node)))) = Node));
219
220 pragma Assert (((Parent (N (Node)) = 0) and then (Tree.Root = Node))
221 or else ((Parent (N (Node)) /= 0) and then
222 ((Left (N (Parent (N (Node)))) = Node)
223 or else
224 (Right (N (Parent (N (Node)))) = Node))));
225
226 if Left (N (Z)) = 0 then
227 if Right (N (Z)) = 0 then
228 if Z = Tree.First then
229 Tree.First := Parent (N (Z));
230 end if;
231
232 if Z = Tree.Last then
233 Tree.Last := Parent (N (Z));
234 end if;
235
236 if Color (N (Z)) = Black then
237 Delete_Fixup (Tree, Z);
238 end if;
239
240 pragma Assert (Left (N (Z)) = 0);
241 pragma Assert (Right (N (Z)) = 0);
242
243 if Z = Tree.Root then
244 pragma Assert (Tree.Length = 1);
245 pragma Assert (Parent (N (Z)) = 0);
246 Tree.Root := 0;
247 elsif Z = Left (N (Parent (N (Z)))) then
248 Set_Left (N (Parent (N (Z))), 0);
249 else
250 pragma Assert (Z = Right (N (Parent (N (Z)))));
251 Set_Right (N (Parent (N (Z))), 0);
252 end if;
253
254 else
255 pragma Assert (Z /= Tree.Last);
256
257 X := Right (N (Z));
258
259 if Z = Tree.First then
260 Tree.First := Min (Tree, X);
261 end if;
262
263 if Z = Tree.Root then
264 Tree.Root := X;
265 elsif Z = Left (N (Parent (N (Z)))) then
266 Set_Left (N (Parent (N (Z))), X);
267 else
268 pragma Assert (Z = Right (N (Parent (N (Z)))));
269 Set_Right (N (Parent (N (Z))), X);
270 end if;
271
272 Set_Parent (N (X), Parent (N (Z)));
273
274 if Color (N (Z)) = Black then
275 Delete_Fixup (Tree, X);
276 end if;
277 end if;
278
279 elsif Right (N (Z)) = 0 then
280 pragma Assert (Z /= Tree.First);
281
282 X := Left (N (Z));
283
284 if Z = Tree.Last then
285 Tree.Last := Max (Tree, X);
286 end if;
287
288 if Z = Tree.Root then
289 Tree.Root := X;
290 elsif Z = Left (N (Parent (N (Z)))) then
291 Set_Left (N (Parent (N (Z))), X);
292 else
293 pragma Assert (Z = Right (N (Parent (N (Z)))));
294 Set_Right (N (Parent (N (Z))), X);
295 end if;
296
297 Set_Parent (N (X), Parent (N (Z)));
298
299 if Color (N (Z)) = Black then
300 Delete_Fixup (Tree, X);
301 end if;
302
303 else
304 pragma Assert (Z /= Tree.First);
305 pragma Assert (Z /= Tree.Last);
306
307 Y := Next (Tree, Z);
308 pragma Assert (Left (N (Y)) = 0);
309
310 X := Right (N (Y));
311
312 if X = 0 then
313 if Y = Left (N (Parent (N (Y)))) then
314 pragma Assert (Parent (N (Y)) /= Z);
315 Delete_Swap (Tree, Z, Y);
316 Set_Left (N (Parent (N (Z))), Z);
317
318 else
319 pragma Assert (Y = Right (N (Parent (N (Y)))));
320 pragma Assert (Parent (N (Y)) = Z);
321 Set_Parent (N (Y), Parent (N (Z)));
322
323 if Z = Tree.Root then
324 Tree.Root := Y;
325 elsif Z = Left (N (Parent (N (Z)))) then
326 Set_Left (N (Parent (N (Z))), Y);
327 else
328 pragma Assert (Z = Right (N (Parent (N (Z)))));
329 Set_Right (N (Parent (N (Z))), Y);
330 end if;
331
332 Set_Left (N (Y), Left (N (Z)));
333 Set_Parent (N (Left (N (Y))), Y);
334 Set_Right (N (Y), Z);
335
336 Set_Parent (N (Z), Y);
337 Set_Left (N (Z), 0);
338 Set_Right (N (Z), 0);
339
340 declare
341 Y_Color : constant Color_Type := Color (N (Y));
342 begin
343 Set_Color (N (Y), Color (N (Z)));
344 Set_Color (N (Z), Y_Color);
345 end;
346 end if;
347
348 if Color (N (Z)) = Black then
349 Delete_Fixup (Tree, Z);
350 end if;
351
352 pragma Assert (Left (N (Z)) = 0);
353 pragma Assert (Right (N (Z)) = 0);
354
355 if Z = Right (N (Parent (N (Z)))) then
356 Set_Right (N (Parent (N (Z))), 0);
357 else
358 pragma Assert (Z = Left (N (Parent (N (Z)))));
359 Set_Left (N (Parent (N (Z))), 0);
360 end if;
361
362 else
363 if Y = Left (N (Parent (N (Y)))) then
364 pragma Assert (Parent (N (Y)) /= Z);
365
366 Delete_Swap (Tree, Z, Y);
367
368 Set_Left (N (Parent (N (Z))), X);
369 Set_Parent (N (X), Parent (N (Z)));
370
371 else
372 pragma Assert (Y = Right (N (Parent (N (Y)))));
373 pragma Assert (Parent (N (Y)) = Z);
374
375 Set_Parent (N (Y), Parent (N (Z)));
376
377 if Z = Tree.Root then
378 Tree.Root := Y;
379 elsif Z = Left (N (Parent (N (Z)))) then
380 Set_Left (N (Parent (N (Z))), Y);
381 else
382 pragma Assert (Z = Right (N (Parent (N (Z)))));
383 Set_Right (N (Parent (N (Z))), Y);
384 end if;
385
386 Set_Left (N (Y), Left (N (Z)));
387 Set_Parent (N (Left (N (Y))), Y);
388
389 declare
390 Y_Color : constant Color_Type := Color (N (Y));
391 begin
392 Set_Color (N (Y), Color (N (Z)));
393 Set_Color (N (Z), Y_Color);
394 end;
395 end if;
396
397 if Color (N (Z)) = Black then
398 Delete_Fixup (Tree, X);
399 end if;
400 end if;
401 end if;
402
403 Tree.Length := Tree.Length - 1;
404 end Delete_Node_Sans_Free;
405
406 -----------------
407 -- Delete_Swap --
408 -----------------
409
410 procedure Delete_Swap
411 (Tree : in out Tree_Type'Class;
412 Z, Y : Count_Type)
413 is
414 N : Nodes_Type renames Tree.Nodes;
415
416 pragma Assert (Z /= Y);
417 pragma Assert (Parent (N (Y)) /= Z);
418
419 Y_Parent : constant Count_Type := Parent (N (Y));
420 Y_Color : constant Color_Type := Color (N (Y));
421
422 begin
423 Set_Parent (N (Y), Parent (N (Z)));
424 Set_Left (N (Y), Left (N (Z)));
425 Set_Right (N (Y), Right (N (Z)));
426 Set_Color (N (Y), Color (N (Z)));
427
428 if Tree.Root = Z then
429 Tree.Root := Y;
430 elsif Right (N (Parent (N (Y)))) = Z then
431 Set_Right (N (Parent (N (Y))), Y);
432 else
433 pragma Assert (Left (N (Parent (N (Y)))) = Z);
434 Set_Left (N (Parent (N (Y))), Y);
435 end if;
436
437 if Right (N (Y)) /= 0 then
438 Set_Parent (N (Right (N (Y))), Y);
439 end if;
440
441 if Left (N (Y)) /= 0 then
442 Set_Parent (N (Left (N (Y))), Y);
443 end if;
444
445 Set_Parent (N (Z), Y_Parent);
446 Set_Color (N (Z), Y_Color);
447 Set_Left (N (Z), 0);
448 Set_Right (N (Z), 0);
449 end Delete_Swap;
450
451 ----------
452 -- Free --
453 ----------
454
455 procedure Free (Tree : in out Tree_Type'Class; X : Count_Type) is
456 pragma Assert (X > 0);
457 pragma Assert (X <= Tree.Capacity);
458
459 N : Nodes_Type renames Tree.Nodes;
460 -- pragma Assert (N (X).Prev >= 0); -- node is active
461 -- Find a way to mark a node as active vs. inactive; we could
462 -- use a special value in Color_Type for this. ???
463
464 begin
465 -- The set container actually contains two data structures: a list for
466 -- the "active" nodes that contain elements that have been inserted
467 -- onto the tree, and another for the "inactive" nodes of the free
468 -- store.
469 --
470 -- We desire that merely declaring an object should have only minimal
471 -- cost; specially, we want to avoid having to initialize the free
472 -- store (to fill in the links), especially if the capacity is large.
473 --
474 -- The head of the free list is indicated by Container.Free. If its
475 -- value is non-negative, then the free store has been initialized
476 -- in the "normal" way: Container.Free points to the head of the list
477 -- of free (inactive) nodes, and the value 0 means the free list is
478 -- empty. Each node on the free list has been initialized to point
479 -- to the next free node (via its Parent component), and the value 0
480 -- means that this is the last free node.
481 --
482 -- If Container.Free is negative, then the links on the free store
483 -- have not been initialized. In this case the link values are
484 -- implied: the free store comprises the components of the node array
485 -- started with the absolute value of Container.Free, and continuing
486 -- until the end of the array (Nodes'Last).
487 --
488 -- ???
489 -- It might be possible to perform an optimization here. Suppose that
490 -- the free store can be represented as having two parts: one
491 -- comprising the non-contiguous inactive nodes linked together
492 -- in the normal way, and the other comprising the contiguous
493 -- inactive nodes (that are not linked together, at the end of the
494 -- nodes array). This would allow us to never have to initialize
495 -- the free store, except in a lazy way as nodes become inactive.
496
497 -- When an element is deleted from the list container, its node
498 -- becomes inactive, and so we set its Prev component to a negative
499 -- value, to indicate that it is now inactive. This provides a useful
500 -- way to detect a dangling cursor reference.
501
502 -- The comment above is incorrect; we need some other way to
503 -- indicate a node is inactive, for example by using a special
504 -- Color_Type value. ???
505 -- N (X).Prev := -1; -- Node is deallocated (not on active list)
506
507 if Tree.Free >= 0 then
508 -- The free store has previously been initialized. All we need to
509 -- do here is link the newly-free'd node onto the free list.
510
511 Set_Parent (N (X), Tree.Free);
512 Tree.Free := X;
513
514 elsif X + 1 = abs Tree.Free then
515 -- The free store has not been initialized, and the node becoming
516 -- inactive immediately precedes the start of the free store. All
517 -- we need to do is move the start of the free store back by one.
518
519 Tree.Free := Tree.Free + 1;
520
521 else
522 -- The free store has not been initialized, and the node becoming
523 -- inactive does not immediately precede the free store. Here we
524 -- first initialize the free store (meaning the links are given
525 -- values in the traditional way), and then link the newly-free'd
526 -- node onto the head of the free store.
527
528 -- ???
529 -- See the comments above for an optimization opportunity. If the
530 -- next link for a node on the free store is negative, then this
531 -- means the remaining nodes on the free store are physically
532 -- contiguous, starting as the absolute value of that index value.
533
534 Tree.Free := abs Tree.Free;
535
536 if Tree.Free > Tree.Capacity then
537 Tree.Free := 0;
538
539 else
540 for I in Tree.Free .. Tree.Capacity - 1 loop
541 Set_Parent (N (I), I + 1);
542 end loop;
543
544 Set_Parent (N (Tree.Capacity), 0);
545 end if;
546
547 Set_Parent (N (X), Tree.Free);
548 Tree.Free := X;
549 end if;
550 end Free;
551
552 -----------------------
553 -- Generic_Allocate --
554 -----------------------
555
556 procedure Generic_Allocate
557 (Tree : in out Tree_Type'Class;
558 Node : out Count_Type)
559 is
560 N : Nodes_Type renames Tree.Nodes;
561
562 begin
563 if Tree.Free >= 0 then
564 Node := Tree.Free;
565
566 -- We always perform the assignment first, before we
567 -- change container state, in order to defend against
568 -- exceptions duration assignment.
569
570 Set_Element (N (Node));
571 Tree.Free := Parent (N (Node));
572
573 else
574 -- A negative free store value means that the links of the nodes
575 -- in the free store have not been initialized. In this case, the
576 -- nodes are physically contiguous in the array, starting at the
577 -- index that is the absolute value of the Container.Free, and
578 -- continuing until the end of the array (Nodes'Last).
579
580 Node := abs Tree.Free;
581
582 -- As above, we perform this assignment first, before modifying
583 -- any container state.
584
585 Set_Element (N (Node));
586 Tree.Free := Tree.Free - 1;
587 end if;
588
589 -- When a node is allocated from the free store, its pointer components
590 -- (the links to other nodes in the tree) must also be initialized (to
591 -- 0, the equivalent of null). This simplifies the post-allocation
592 -- handling of nodes inserted into terminal positions.
593
594 Set_Parent (N (Node), Parent => 0);
595 Set_Left (N (Node), Left => 0);
596 Set_Right (N (Node), Right => 0);
597 end Generic_Allocate;
598
599 -------------------
600 -- Generic_Equal --
601 -------------------
602
603 function Generic_Equal (Left, Right : Tree_Type'Class) return Boolean is
604 -- Per AI05-0022, the container implementation is required to detect
605 -- element tampering by a generic actual subprogram.
606
607 Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
608 Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
609
610 L_Node : Count_Type;
611 R_Node : Count_Type;
612
613 begin
614 if Left'Address = Right'Address then
615 return True;
616 end if;
617
618 if Left.Length /= Right.Length then
619 return False;
620 end if;
621
622 -- If the containers are empty, return a result immediately, so as to
623 -- not manipulate the tamper bits unnecessarily.
624
625 if Left.Length = 0 then
626 return True;
627 end if;
628
629 L_Node := Left.First;
630 R_Node := Right.First;
631 while L_Node /= 0 loop
632 if not Is_Equal (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
633 return False;
634 end if;
635
636 L_Node := Next (Left, L_Node);
637 R_Node := Next (Right, 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'Class) is
648 procedure Iterate (P : Count_Type);
649
650 -------------
651 -- Iterate --
652 -------------
653
654 procedure Iterate (P : Count_Type) is
655 X : Count_Type := P;
656 begin
657 while X /= 0 loop
658 Iterate (Left (Tree.Nodes (X)));
659 Process (X);
660 X := Right (Tree.Nodes (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 ------------------
671 -- Generic_Read --
672 ------------------
673
674 procedure Generic_Read
675 (Stream : not null access Root_Stream_Type'Class;
676 Tree : in out Tree_Type'Class)
677 is
678 Len : Count_Type'Base;
679
680 Node, Last_Node : Count_Type;
681
682 N : Nodes_Type renames Tree.Nodes;
683
684 begin
685 Clear_Tree (Tree);
686 Count_Type'Base'Read (Stream, Len);
687
688 if Checks and then Len < 0 then
689 raise Program_Error with "bad container length (corrupt stream)";
690 end if;
691
692 if Len = 0 then
693 return;
694 end if;
695
696 if Checks and then Len > Tree.Capacity then
697 raise Constraint_Error with "length exceeds capacity";
698 end if;
699
700 -- Use Unconditional_Insert_With_Hint here instead ???
701
702 Allocate (Tree, Node);
703 pragma Assert (Node /= 0);
704
705 Set_Color (N (Node), Black);
706
707 Tree.Root := Node;
708 Tree.First := Node;
709 Tree.Last := Node;
710 Tree.Length := 1;
711
712 for J in Count_Type range 2 .. Len loop
713 Last_Node := Node;
714 pragma Assert (Last_Node = Tree.Last);
715
716 Allocate (Tree, Node);
717 pragma Assert (Node /= 0);
718
719 Set_Color (N (Node), Red);
720 Set_Right (N (Last_Node), Right => Node);
721 Tree.Last := Node;
722 Set_Parent (N (Node), Parent => Last_Node);
723
724 Rebalance_For_Insert (Tree, Node);
725 Tree.Length := Tree.Length + 1;
726 end loop;
727 end Generic_Read;
728
729 -------------------------------
730 -- Generic_Reverse_Iteration --
731 -------------------------------
732
733 procedure Generic_Reverse_Iteration (Tree : Tree_Type'Class) is
734 procedure Iterate (P : Count_Type);
735
736 -------------
737 -- Iterate --
738 -------------
739
740 procedure Iterate (P : Count_Type) is
741 X : Count_Type := P;
742 begin
743 while X /= 0 loop
744 Iterate (Right (Tree.Nodes (X)));
745 Process (X);
746 X := Left (Tree.Nodes (X));
747 end loop;
748 end Iterate;
749
750 -- Start of processing for Generic_Reverse_Iteration
751
752 begin
753 Iterate (Tree.Root);
754 end Generic_Reverse_Iteration;
755
756 -------------------
757 -- Generic_Write --
758 -------------------
759
760 procedure Generic_Write
761 (Stream : not null access Root_Stream_Type'Class;
762 Tree : Tree_Type'Class)
763 is
764 procedure Process (Node : Count_Type);
765 pragma Inline (Process);
766
767 procedure Iterate is new Generic_Iteration (Process);
768
769 -------------
770 -- Process --
771 -------------
772
773 procedure Process (Node : Count_Type) is
774 begin
775 Write_Node (Stream, Tree.Nodes (Node));
776 end Process;
777
778 -- Start of processing for Generic_Write
779
780 begin
781 Count_Type'Base'Write (Stream, Tree.Length);
782 Iterate (Tree);
783 end Generic_Write;
784
785 -----------------
786 -- Left_Rotate --
787 -----------------
788
789 procedure Left_Rotate (Tree : in out Tree_Type'Class; X : Count_Type) is
790
791 -- CLR p. 266
792
793 N : Nodes_Type renames Tree.Nodes;
794
795 Y : constant Count_Type := Right (N (X));
796 pragma Assert (Y /= 0);
797
798 begin
799 Set_Right (N (X), Left (N (Y)));
800
801 if Left (N (Y)) /= 0 then
802 Set_Parent (N (Left (N (Y))), X);
803 end if;
804
805 Set_Parent (N (Y), Parent (N (X)));
806
807 if X = Tree.Root then
808 Tree.Root := Y;
809 elsif X = Left (N (Parent (N (X)))) then
810 Set_Left (N (Parent (N (X))), Y);
811 else
812 pragma Assert (X = Right (N (Parent (N (X)))));
813 Set_Right (N (Parent (N (X))), Y);
814 end if;
815
816 Set_Left (N (Y), X);
817 Set_Parent (N (X), Y);
818 end Left_Rotate;
819
820 ---------
821 -- Max --
822 ---------
823
824 function Max
825 (Tree : Tree_Type'Class;
826 Node : Count_Type) return Count_Type
827 is
828 -- CLR p. 248
829
830 X : Count_Type := Node;
831 Y : Count_Type;
832
833 begin
834 loop
835 Y := Right (Tree.Nodes (X));
836
837 if Y = 0 then
838 return X;
839 end if;
840
841 X := Y;
842 end loop;
843 end Max;
844
845 ---------
846 -- Min --
847 ---------
848
849 function Min
850 (Tree : Tree_Type'Class;
851 Node : Count_Type) return Count_Type
852 is
853 -- CLR p. 248
854
855 X : Count_Type := Node;
856 Y : Count_Type;
857
858 begin
859 loop
860 Y := Left (Tree.Nodes (X));
861
862 if Y = 0 then
863 return X;
864 end if;
865
866 X := Y;
867 end loop;
868 end Min;
869
870 ----------
871 -- Next --
872 ----------
873
874 function Next
875 (Tree : Tree_Type'Class;
876 Node : Count_Type) return Count_Type
877 is
878 begin
879 -- CLR p. 249
880
881 if Node = 0 then
882 return 0;
883 end if;
884
885 if Right (Tree.Nodes (Node)) /= 0 then
886 return Min (Tree, Right (Tree.Nodes (Node)));
887 end if;
888
889 declare
890 X : Count_Type := Node;
891 Y : Count_Type := Parent (Tree.Nodes (Node));
892
893 begin
894 while Y /= 0 and then X = Right (Tree.Nodes (Y)) loop
895 X := Y;
896 Y := Parent (Tree.Nodes (Y));
897 end loop;
898
899 return Y;
900 end;
901 end Next;
902
903 --------------
904 -- Previous --
905 --------------
906
907 function Previous
908 (Tree : Tree_Type'Class;
909 Node : Count_Type) return Count_Type
910 is
911 begin
912 if Node = 0 then
913 return 0;
914 end if;
915
916 if Left (Tree.Nodes (Node)) /= 0 then
917 return Max (Tree, Left (Tree.Nodes (Node)));
918 end if;
919
920 declare
921 X : Count_Type := Node;
922 Y : Count_Type := Parent (Tree.Nodes (Node));
923
924 begin
925 while Y /= 0 and then X = Left (Tree.Nodes (Y)) loop
926 X := Y;
927 Y := Parent (Tree.Nodes (Y));
928 end loop;
929
930 return Y;
931 end;
932 end Previous;
933
934 --------------------------
935 -- Rebalance_For_Insert --
936 --------------------------
937
938 procedure Rebalance_For_Insert
939 (Tree : in out Tree_Type'Class;
940 Node : Count_Type)
941 is
942 -- CLR p. 268
943
944 N : Nodes_Type renames Tree.Nodes;
945
946 X : Count_Type := Node;
947 pragma Assert (X /= 0);
948 pragma Assert (Color (N (X)) = Red);
949
950 Y : Count_Type;
951
952 begin
953 while X /= Tree.Root and then Color (N (Parent (N (X)))) = Red loop
954 if Parent (N (X)) = Left (N (Parent (N (Parent (N (X)))))) then
955 Y := Right (N (Parent (N (Parent (N (X))))));
956
957 if Y /= 0 and then Color (N (Y)) = Red then
958 Set_Color (N (Parent (N (X))), Black);
959 Set_Color (N (Y), Black);
960 Set_Color (N (Parent (N (Parent (N (X))))), Red);
961 X := Parent (N (Parent (N (X))));
962
963 else
964 if X = Right (N (Parent (N (X)))) then
965 X := Parent (N (X));
966 Left_Rotate (Tree, X);
967 end if;
968
969 Set_Color (N (Parent (N (X))), Black);
970 Set_Color (N (Parent (N (Parent (N (X))))), Red);
971 Right_Rotate (Tree, Parent (N (Parent (N (X)))));
972 end if;
973
974 else
975 pragma Assert (Parent (N (X)) =
976 Right (N (Parent (N (Parent (N (X)))))));
977
978 Y := Left (N (Parent (N (Parent (N (X))))));
979
980 if Y /= 0 and then Color (N (Y)) = Red then
981 Set_Color (N (Parent (N (X))), Black);
982 Set_Color (N (Y), Black);
983 Set_Color (N (Parent (N (Parent (N (X))))), Red);
984 X := Parent (N (Parent (N (X))));
985
986 else
987 if X = Left (N (Parent (N (X)))) then
988 X := Parent (N (X));
989 Right_Rotate (Tree, X);
990 end if;
991
992 Set_Color (N (Parent (N (X))), Black);
993 Set_Color (N (Parent (N (Parent (N (X))))), Red);
994 Left_Rotate (Tree, Parent (N (Parent (N (X)))));
995 end if;
996 end if;
997 end loop;
998
999 Set_Color (N (Tree.Root), Black);
1000 end Rebalance_For_Insert;
1001
1002 ------------------
1003 -- Right_Rotate --
1004 ------------------
1005
1006 procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type) is
1007 N : Nodes_Type renames Tree.Nodes;
1008
1009 X : constant Count_Type := Left (N (Y));
1010 pragma Assert (X /= 0);
1011
1012 begin
1013 Set_Left (N (Y), Right (N (X)));
1014
1015 if Right (N (X)) /= 0 then
1016 Set_Parent (N (Right (N (X))), Y);
1017 end if;
1018
1019 Set_Parent (N (X), Parent (N (Y)));
1020
1021 if Y = Tree.Root then
1022 Tree.Root := X;
1023 elsif Y = Left (N (Parent (N (Y)))) then
1024 Set_Left (N (Parent (N (Y))), X);
1025 else
1026 pragma Assert (Y = Right (N (Parent (N (Y)))));
1027 Set_Right (N (Parent (N (Y))), X);
1028 end if;
1029
1030 Set_Right (N (X), Y);
1031 Set_Parent (N (Y), X);
1032 end Right_Rotate;
1033
1034 ---------
1035 -- Vet --
1036 ---------
1037
1038 function Vet (Tree : Tree_Type'Class; Index : Count_Type) return Boolean is
1039 Nodes : Nodes_Type renames Tree.Nodes;
1040 Node : Node_Type renames Nodes (Index);
1041
1042 begin
1043 if Parent (Node) = Index
1044 or else Left (Node) = Index
1045 or else Right (Node) = Index
1046 then
1047 return False;
1048 end if;
1049
1050 if Tree.Length = 0
1051 or else Tree.Root = 0
1052 or else Tree.First = 0
1053 or else Tree.Last = 0
1054 then
1055 return False;
1056 end if;
1057
1058 if Parent (Nodes (Tree.Root)) /= 0 then
1059 return False;
1060 end if;
1061
1062 if Left (Nodes (Tree.First)) /= 0 then
1063 return False;
1064 end if;
1065
1066 if Right (Nodes (Tree.Last)) /= 0 then
1067 return False;
1068 end if;
1069
1070 if Tree.Length = 1 then
1071 if Tree.First /= Tree.Last
1072 or else Tree.First /= Tree.Root
1073 then
1074 return False;
1075 end if;
1076
1077 if Index /= Tree.First then
1078 return False;
1079 end if;
1080
1081 if Parent (Node) /= 0
1082 or else Left (Node) /= 0
1083 or else Right (Node) /= 0
1084 then
1085 return False;
1086 end if;
1087
1088 return True;
1089 end if;
1090
1091 if Tree.First = Tree.Last then
1092 return False;
1093 end if;
1094
1095 if Tree.Length = 2 then
1096 if Tree.First /= Tree.Root and then Tree.Last /= Tree.Root then
1097 return False;
1098 end if;
1099
1100 if Tree.First /= Index and then Tree.Last /= Index then
1101 return False;
1102 end if;
1103 end if;
1104
1105 if Left (Node) /= 0 and then Parent (Nodes (Left (Node))) /= Index then
1106 return False;
1107 end if;
1108
1109 if Right (Node) /= 0 and then Parent (Nodes (Right (Node))) /= Index then
1110 return False;
1111 end if;
1112
1113 if Parent (Node) = 0 then
1114 if Tree.Root /= Index then
1115 return False;
1116 end if;
1117
1118 elsif Left (Nodes (Parent (Node))) /= Index
1119 and then Right (Nodes (Parent (Node))) /= Index
1120 then
1121 return False;
1122 end if;
1123
1124 return True;
1125 end Vet;
1126
1127 end Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;