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