1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
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 --
10 -- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
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 --
20 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
21 -- Boston, MA 02110-1301, USA. --
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. --
30 -- This unit was originally developed by Matthew J Heaney. --
31 ------------------------------------------------------------------------------
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)
40 with System; use type System.Address;
42 package body Ada.Containers.Red_Black_Trees.Generic_Operations is
44 -----------------------
45 -- Local Subprograms --
46 -----------------------
48 procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access);
50 procedure Delete_Swap (Tree : in out Tree_Type; Z, Y : Node_Access);
52 procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access);
53 procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access);
55 -- ---------------------
56 -- -- Check_Invariant --
57 -- ---------------------
59 -- procedure Check_Invariant (Tree : Tree_Type) is
60 -- Root : constant Node_Access := Tree.Root;
62 -- function Check (Node : Node_Access) return Natural;
68 -- function Check (Node : Node_Access) return Natural is
70 -- if Node = null then
74 -- if Color (Node) = Red then
76 -- L : constant Node_Access := Left (Node);
78 -- pragma Assert (L = null or else Color (L) = Black);
83 -- R : constant Node_Access := Right (Node);
85 -- pragma Assert (R = null or else Color (R) = Black);
90 -- NL : constant Natural := Check (Left (Node));
91 -- NR : constant Natural := Check (Right (Node));
93 -- pragma Assert (NL = NR);
99 -- NL : constant Natural := Check (Left (Node));
100 -- NR : constant Natural := Check (Right (Node));
102 -- pragma Assert (NL = NR);
107 -- -- Start of processing for Check_Invariant
110 -- if Root = null then
111 -- pragma Assert (Tree.First = null);
112 -- pragma Assert (Tree.Last = null);
113 -- pragma Assert (Tree.Length = 0);
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);
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);
135 -- pragma Assert (NL = NR);
139 -- end Check_Invariant;
145 procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access) is
149 X : Node_Access := Node;
154 and then Color (X) = Black
156 if X = Left (Parent (X)) then
157 W := Right (Parent (X));
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));
166 if (Left (W) = null or else Color (Left (W)) = Black)
168 (Right (W) = null or else Color (Right (W)) = Black)
175 or else Color (Right (W)) = Black
177 if Left (W) /= null then
178 Set_Color (Left (W), Black);
182 Right_Rotate (Tree, W);
183 W := Right (Parent (X));
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));
194 pragma Assert (X = Right (Parent (X)));
196 W := Left (Parent (X));
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));
205 if (Left (W) = null or else Color (Left (W)) = Black)
207 (Right (W) = null or else Color (Right (W)) = Black)
213 if Left (W) = null or else Color (Left (W)) = Black then
214 if Right (W) /= null then
215 Set_Color (Right (W), Black);
219 Left_Rotate (Tree, W);
220 W := Left (Parent (X));
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));
232 Set_Color (X, Black);
235 ---------------------------
236 -- Delete_Node_Sans_Free --
237 ---------------------------
239 procedure Delete_Node_Sans_Free
240 (Tree : in out Tree_Type;
247 Z : constant Node_Access := Node;
248 pragma Assert (Z /= null);
251 if Tree.Busy > 0 then
252 raise Program_Error with
253 "attempt to tamper with cursors (container is busy)";
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))));
273 if Left (Z) = null then
274 if Right (Z) = null then
275 if Z = Tree.First then
276 Tree.First := Parent (Z);
279 if Z = Tree.Last then
280 Tree.Last := Parent (Z);
283 if Color (Z) = Black then
284 Delete_Fixup (Tree, Z);
287 pragma Assert (Left (Z) = null);
288 pragma Assert (Right (Z) = null);
290 if Z = Tree.Root then
291 pragma Assert (Tree.Length = 1);
292 pragma Assert (Parent (Z) = null);
294 elsif Z = Left (Parent (Z)) then
295 Set_Left (Parent (Z), null);
297 pragma Assert (Z = Right (Parent (Z)));
298 Set_Right (Parent (Z), null);
302 pragma Assert (Z /= Tree.Last);
306 if Z = Tree.First then
307 Tree.First := Min (X);
310 if Z = Tree.Root then
312 elsif Z = Left (Parent (Z)) then
313 Set_Left (Parent (Z), X);
315 pragma Assert (Z = Right (Parent (Z)));
316 Set_Right (Parent (Z), X);
319 Set_Parent (X, Parent (Z));
321 if Color (Z) = Black then
322 Delete_Fixup (Tree, X);
326 elsif Right (Z) = null then
327 pragma Assert (Z /= Tree.First);
331 if Z = Tree.Last then
332 Tree.Last := Max (X);
335 if Z = Tree.Root then
337 elsif Z = Left (Parent (Z)) then
338 Set_Left (Parent (Z), X);
340 pragma Assert (Z = Right (Parent (Z)));
341 Set_Right (Parent (Z), X);
344 Set_Parent (X, Parent (Z));
346 if Color (Z) = Black then
347 Delete_Fixup (Tree, X);
351 pragma Assert (Z /= Tree.First);
352 pragma Assert (Z /= Tree.Last);
355 pragma Assert (Left (Y) = null);
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);
366 pragma Assert (Y = Right (Parent (Y)));
367 pragma Assert (Parent (Y) = Z);
368 Set_Parent (Y, Parent (Z));
370 if Z = Tree.Root then
372 elsif Z = Left (Parent (Z)) then
373 Set_Left (Parent (Z), Y);
375 pragma Assert (Z = Right (Parent (Z)));
376 Set_Right (Parent (Z), Y);
379 Set_Left (Y, Left (Z));
380 Set_Parent (Left (Y), Y);
387 Y_Color : constant Color_Type := Color (Y);
389 Set_Color (Y, Color (Z));
390 Set_Color (Z, Y_Color);
394 if Color (Z) = Black then
395 Delete_Fixup (Tree, Z);
398 pragma Assert (Left (Z) = null);
399 pragma Assert (Right (Z) = null);
401 if Z = Right (Parent (Z)) then
402 Set_Right (Parent (Z), null);
404 pragma Assert (Z = Left (Parent (Z)));
405 Set_Left (Parent (Z), null);
409 if Y = Left (Parent (Y)) then
410 pragma Assert (Parent (Y) /= Z);
412 Delete_Swap (Tree, Z, Y);
414 Set_Left (Parent (Z), X);
415 Set_Parent (X, Parent (Z));
418 pragma Assert (Y = Right (Parent (Y)));
419 pragma Assert (Parent (Y) = Z);
421 Set_Parent (Y, Parent (Z));
423 if Z = Tree.Root then
425 elsif Z = Left (Parent (Z)) then
426 Set_Left (Parent (Z), Y);
428 pragma Assert (Z = Right (Parent (Z)));
429 Set_Right (Parent (Z), Y);
432 Set_Left (Y, Left (Z));
433 Set_Parent (Left (Y), Y);
436 Y_Color : constant Color_Type := Color (Y);
438 Set_Color (Y, Color (Z));
439 Set_Color (Z, Y_Color);
443 if Color (Z) = Black then
444 Delete_Fixup (Tree, X);
449 Tree.Length := Tree.Length - 1;
450 end Delete_Node_Sans_Free;
456 procedure Delete_Swap
457 (Tree : in out Tree_Type;
460 pragma Assert (Z /= Y);
461 pragma Assert (Parent (Y) /= Z);
463 Y_Parent : constant Node_Access := Parent (Y);
464 Y_Color : constant Color_Type := Color (Y);
467 Set_Parent (Y, Parent (Z));
468 Set_Left (Y, Left (Z));
469 Set_Right (Y, Right (Z));
470 Set_Color (Y, Color (Z));
472 if Tree.Root = Z then
474 elsif Right (Parent (Y)) = Z then
475 Set_Right (Parent (Y), Y);
477 pragma Assert (Left (Parent (Y)) = Z);
478 Set_Left (Parent (Y), Y);
481 if Right (Y) /= null then
482 Set_Parent (Right (Y), Y);
485 if Left (Y) /= null then
486 Set_Parent (Left (Y), Y);
489 Set_Parent (Z, Y_Parent);
490 Set_Color (Z, Y_Color);
499 procedure Generic_Adjust (Tree : in out Tree_Type) is
500 N : constant Count_Type := Tree.Length;
501 Root : constant Node_Access := Tree.Root;
505 pragma Assert (Root = null);
506 pragma Assert (Tree.Busy = 0);
507 pragma Assert (Tree.Lock = 0);
516 Tree.Root := Copy_Tree (Root);
517 Tree.First := Min (Tree.Root);
518 Tree.Last := Max (Tree.Root);
526 procedure Generic_Clear (Tree : in out Tree_Type) is
527 Root : Node_Access := Tree.Root;
529 if Tree.Busy > 0 then
530 raise Program_Error with
531 "attempt to tamper with cursors (container is busy)";
534 Tree := (First => null,
544 -----------------------
545 -- Generic_Copy_Tree --
546 -----------------------
548 function Generic_Copy_Tree (Source_Root : Node_Access) return Node_Access is
549 Target_Root : Node_Access := Copy_Node (Source_Root);
553 if Right (Source_Root) /= null then
555 (Node => Target_Root,
556 Right => Generic_Copy_Tree (Right (Source_Root)));
559 (Node => Right (Target_Root),
560 Parent => Target_Root);
565 X := Left (Source_Root);
568 Y : constant Node_Access := Copy_Node (X);
570 Set_Left (Node => P, Left => Y);
571 Set_Parent (Node => Y, Parent => P);
573 if Right (X) /= null then
576 Right => Generic_Copy_Tree (Right (X)));
591 Delete_Tree (Target_Root);
593 end Generic_Copy_Tree;
595 -------------------------
596 -- Generic_Delete_Tree --
597 -------------------------
599 procedure Generic_Delete_Tree (X : in out Node_Access) is
601 pragma Warnings (Off, Y);
605 Generic_Delete_Tree (Y);
610 end Generic_Delete_Tree;
616 function Generic_Equal (Left, Right : Tree_Type) return Boolean is
617 L_Node : Node_Access;
618 R_Node : Node_Access;
621 if Left'Address = Right'Address then
625 if Left.Length /= Right.Length then
629 L_Node := Left.First;
630 R_Node := Right.First;
631 while L_Node /= null loop
632 if not Is_Equal (L_Node, R_Node) then
636 L_Node := Next (L_Node);
637 R_Node := Next (R_Node);
643 -----------------------
644 -- Generic_Iteration --
645 -----------------------
647 procedure Generic_Iteration (Tree : Tree_Type) is
648 procedure Iterate (P : Node_Access);
654 procedure Iterate (P : Node_Access) is
655 X : Node_Access := P;
664 -- Start of processing for Generic_Iteration
668 end Generic_Iteration;
674 procedure Generic_Move (Target, Source : in out Tree_Type) is
676 if Target'Address = Source'Address then
680 if Source.Busy > 0 then
681 raise Program_Error with
682 "attempt to tamper with cursors (container is busy)";
689 Source := (First => null,
701 procedure Generic_Read
702 (Stream : not null access Root_Stream_Type'Class;
703 Tree : in out Tree_Type)
707 Node, Last_Node : Node_Access;
712 Count_Type'Base'Read (Stream, N);
713 pragma Assert (N >= 0);
719 Node := Read_Node (Stream);
720 pragma Assert (Node /= null);
721 pragma Assert (Color (Node) = Red);
723 Set_Color (Node, Black);
731 for J in Count_Type range 2 .. N loop
733 pragma Assert (Last_Node = Tree.Last);
735 Node := Read_Node (Stream);
736 pragma Assert (Node /= null);
737 pragma Assert (Color (Node) = Red);
739 Set_Right (Node => Last_Node, Right => Node);
741 Set_Parent (Node => Node, Parent => Last_Node);
742 Rebalance_For_Insert (Tree, Node);
743 Tree.Length := Tree.Length + 1;
747 -------------------------------
748 -- Generic_Reverse_Iteration --
749 -------------------------------
751 procedure Generic_Reverse_Iteration (Tree : Tree_Type)
753 procedure Iterate (P : Node_Access);
759 procedure Iterate (P : Node_Access) is
760 X : Node_Access := P;
769 -- Start of processing for Generic_Reverse_Iteration
773 end Generic_Reverse_Iteration;
779 procedure Generic_Write
780 (Stream : not null access Root_Stream_Type'Class;
783 procedure Process (Node : Node_Access);
784 pragma Inline (Process);
787 new Generic_Iteration (Process);
793 procedure Process (Node : Node_Access) is
795 Write_Node (Stream, Node);
798 -- Start of processing for Generic_Write
801 Count_Type'Base'Write (Stream, Tree.Length);
809 procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access) is
813 Y : constant Node_Access := Right (X);
814 pragma Assert (Y /= null);
817 Set_Right (X, Left (Y));
819 if Left (Y) /= null then
820 Set_Parent (Left (Y), X);
823 Set_Parent (Y, Parent (X));
825 if X = Tree.Root then
827 elsif X = Left (Parent (X)) then
828 Set_Left (Parent (X), Y);
830 pragma Assert (X = Right (Parent (X)));
831 Set_Right (Parent (X), Y);
842 function Max (Node : Node_Access) return Node_Access is
846 X : Node_Access := Node;
865 function Min (Node : Node_Access) return Node_Access is
869 X : Node_Access := Node;
888 function Next (Node : Node_Access) return Node_Access is
896 if Right (Node) /= null then
897 return Min (Right (Node));
901 X : Node_Access := Node;
902 Y : Node_Access := Parent (Node);
906 and then X = Right (Y)
920 function Previous (Node : Node_Access) return Node_Access is
926 if Left (Node) /= null then
927 return Max (Left (Node));
931 X : Node_Access := Node;
932 Y : Node_Access := Parent (Node);
936 and then X = Left (Y)
946 --------------------------
947 -- Rebalance_For_Insert --
948 --------------------------
950 procedure Rebalance_For_Insert
951 (Tree : in out Tree_Type;
956 X : Node_Access := Node;
957 pragma Assert (X /= null);
958 pragma Assert (Color (X) = Red);
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)));
967 if Y /= null and then Color (Y) = Red then
968 Set_Color (Parent (X), Black);
969 Set_Color (Y, Black);
970 Set_Color (Parent (Parent (X)), Red);
971 X := Parent (Parent (X));
974 if X = Right (Parent (X)) then
976 Left_Rotate (Tree, X);
979 Set_Color (Parent (X), Black);
980 Set_Color (Parent (Parent (X)), Red);
981 Right_Rotate (Tree, Parent (Parent (X)));
985 pragma Assert (Parent (X) = Right (Parent (Parent (X))));
987 Y := Left (Parent (Parent (X)));
989 if Y /= null and then Color (Y) = Red then
990 Set_Color (Parent (X), Black);
991 Set_Color (Y, Black);
992 Set_Color (Parent (Parent (X)), Red);
993 X := Parent (Parent (X));
996 if X = Left (Parent (X)) then
998 Right_Rotate (Tree, X);
1001 Set_Color (Parent (X), Black);
1002 Set_Color (Parent (Parent (X)), Red);
1003 Left_Rotate (Tree, Parent (Parent (X)));
1008 Set_Color (Tree.Root, Black);
1009 end Rebalance_For_Insert;
1015 procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access) is
1016 X : constant Node_Access := Left (Y);
1017 pragma Assert (X /= null);
1020 Set_Left (Y, Right (X));
1022 if Right (X) /= null then
1023 Set_Parent (Right (X), Y);
1026 Set_Parent (X, Parent (Y));
1028 if Y = Tree.Root then
1030 elsif Y = Left (Parent (Y)) then
1031 Set_Left (Parent (Y), X);
1033 pragma Assert (Y = Right (Parent (Y)));
1034 Set_Right (Parent (Y), X);
1045 function Vet (Tree : Tree_Type; Node : Node_Access) return Boolean is
1051 if Parent (Node) = Node
1052 or else Left (Node) = Node
1053 or else Right (Node) = Node
1059 or else Tree.Root = null
1060 or else Tree.First = null
1061 or else Tree.Last = null
1066 if Parent (Tree.Root) /= null then
1070 if Left (Tree.First) /= null then
1074 if Right (Tree.Last) /= null then
1078 if Tree.Length = 1 then
1079 if Tree.First /= Tree.Last
1080 or else Tree.First /= Tree.Root
1085 if Node /= Tree.First then
1089 if Parent (Node) /= null
1090 or else Left (Node) /= null
1091 or else Right (Node) /= null
1099 if Tree.First = Tree.Last then
1103 if Tree.Length = 2 then
1104 if Tree.First /= Tree.Root
1105 and then Tree.Last /= Tree.Root
1110 if Tree.First /= Node
1111 and then Tree.Last /= Node
1117 if Left (Node) /= null
1118 and then Parent (Left (Node)) /= Node
1123 if Right (Node) /= null
1124 and then Parent (Right (Node)) /= Node
1129 if Parent (Node) = null then
1130 if Tree.Root /= Node then
1134 elsif Left (Parent (Node)) /= Node
1135 and then Right (Parent (Node)) /= Node
1143 end Ada.Containers.Red_Black_Trees.Generic_Operations;