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-2005, Free Software Foundation, Inc. --
12 -- This specification is derived from the Ada Reference Manual for use with --
13 -- GNAT. The copyright notice above, and the license provisions that follow --
14 -- apply solely to the contents of the part following the private keyword. --
16 -- GNAT is free software; you can redistribute it and/or modify it under --
17 -- terms of the GNU General Public License as published by the Free Soft- --
18 -- ware Foundation; either version 2, or (at your option) any later ver- --
19 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
20 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
21 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
22 -- for more details. You should have received a copy of the GNU General --
23 -- Public License distributed with GNAT; see file COPYING. If not, write --
24 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
25 -- Boston, MA 02110-1301, USA. --
27 -- As a special exception, if other files instantiate generics from this --
28 -- unit, or you link this unit with other files to produce an executable, --
29 -- this unit does not by itself cause the resulting executable to be --
30 -- covered by the GNU General Public License. This exception does not --
31 -- however invalidate any other reasons why the executable file might be --
32 -- covered by the GNU Public License. --
34 -- This unit was originally developed by Matthew J Heaney. --
35 ------------------------------------------------------------------------------
37 with System; use type System.Address;
39 package body Ada.Containers.Red_Black_Trees.Generic_Operations is
41 -----------------------
42 -- Local Subprograms --
43 -----------------------
45 procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access);
47 procedure Delete_Swap (Tree : in out Tree_Type; Z, Y : Node_Access);
49 procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access);
50 procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access);
52 -- ---------------------
53 -- -- Check_Invariant --
54 -- ---------------------
56 -- procedure Check_Invariant (Tree : Tree_Type) is
57 -- Root : constant Node_Access := Tree.Root;
59 -- function Check (Node : Node_Access) return Natural;
65 -- function Check (Node : Node_Access) return Natural is
67 -- if Node = null then
71 -- if Color (Node) = Red then
73 -- L : constant Node_Access := Left (Node);
75 -- pragma Assert (L = null or else Color (L) = Black);
80 -- R : constant Node_Access := Right (Node);
82 -- pragma Assert (R = null or else Color (R) = Black);
87 -- NL : constant Natural := Check (Left (Node));
88 -- NR : constant Natural := Check (Right (Node));
90 -- pragma Assert (NL = NR);
96 -- NL : constant Natural := Check (Left (Node));
97 -- NR : constant Natural := Check (Right (Node));
99 -- pragma Assert (NL = NR);
104 -- -- Start of processing for Check_Invariant
107 -- if Root = null then
108 -- pragma Assert (Tree.First = null);
109 -- pragma Assert (Tree.Last = null);
110 -- pragma Assert (Tree.Length = 0);
114 -- pragma Assert (Color (Root) = Black);
115 -- pragma Assert (Tree.Length > 0);
116 -- pragma Assert (Tree.Root /= null);
117 -- pragma Assert (Tree.First /= null);
118 -- pragma Assert (Tree.Last /= null);
119 -- pragma Assert (Parent (Tree.Root) = null);
120 -- pragma Assert ((Tree.Length > 1)
121 -- or else (Tree.First = Tree.Last
122 -- and Tree.First = Tree.Root));
123 -- pragma Assert (Left (Tree.First) = null);
124 -- pragma Assert (Right (Tree.Last) = null);
127 -- L : constant Node_Access := Left (Root);
128 -- R : constant Node_Access := Right (Root);
129 -- NL : constant Natural := Check (L);
130 -- NR : constant Natural := Check (R);
132 -- pragma Assert (NL = NR);
136 -- end Check_Invariant;
142 procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access) is
146 X : Node_Access := Node;
151 and then Color (X) = Black
153 if X = Left (Parent (X)) then
154 W := Right (Parent (X));
156 if Color (W) = Red then
157 Set_Color (W, Black);
158 Set_Color (Parent (X), Red);
159 Left_Rotate (Tree, Parent (X));
160 W := Right (Parent (X));
163 if (Left (W) = null or else Color (Left (W)) = Black)
165 (Right (W) = null or else Color (Right (W)) = Black)
172 or else Color (Right (W)) = Black
174 if Left (W) /= null then
175 Set_Color (Left (W), Black);
179 Right_Rotate (Tree, W);
180 W := Right (Parent (X));
183 Set_Color (W, Color (Parent (X)));
184 Set_Color (Parent (X), Black);
185 Set_Color (Right (W), Black);
186 Left_Rotate (Tree, Parent (X));
191 pragma Assert (X = Right (Parent (X)));
193 W := Left (Parent (X));
195 if Color (W) = Red then
196 Set_Color (W, Black);
197 Set_Color (Parent (X), Red);
198 Right_Rotate (Tree, Parent (X));
199 W := Left (Parent (X));
202 if (Left (W) = null or else Color (Left (W)) = Black)
204 (Right (W) = null or else Color (Right (W)) = Black)
210 if Left (W) = null or else Color (Left (W)) = Black then
211 if Right (W) /= null then
212 Set_Color (Right (W), Black);
216 Left_Rotate (Tree, W);
217 W := Left (Parent (X));
220 Set_Color (W, Color (Parent (X)));
221 Set_Color (Parent (X), Black);
222 Set_Color (Left (W), Black);
223 Right_Rotate (Tree, Parent (X));
229 Set_Color (X, Black);
232 ---------------------------
233 -- Delete_Node_Sans_Free --
234 ---------------------------
236 procedure Delete_Node_Sans_Free
237 (Tree : in out Tree_Type;
244 Z : constant Node_Access := Node;
245 pragma Assert (Z /= null);
248 if Tree.Busy > 0 then
252 -- pragma Assert (Tree.Length > 0);
253 -- pragma Assert (Tree.Root /= null);
254 -- pragma Assert (Tree.First /= null);
255 -- pragma Assert (Tree.Last /= null);
256 -- pragma Assert (Parent (Tree.Root) = null);
257 -- pragma Assert ((Tree.Length > 1)
258 -- or else (Tree.First = Tree.Last
259 -- and then Tree.First = Tree.Root));
260 -- pragma Assert ((Left (Node) = null)
261 -- or else (Parent (Left (Node)) = Node));
262 -- pragma Assert ((Right (Node) = null)
263 -- or else (Parent (Right (Node)) = Node));
264 -- pragma Assert (((Parent (Node) = null) and then (Tree.Root = Node))
265 -- or else ((Parent (Node) /= null) and then
266 -- ((Left (Parent (Node)) = Node)
267 -- or else (Right (Parent (Node)) = Node))));
269 if Left (Z) = null then
270 if Right (Z) = null then
271 if Z = Tree.First then
272 Tree.First := Parent (Z);
275 if Z = Tree.Last then
276 Tree.Last := Parent (Z);
279 if Color (Z) = Black then
280 Delete_Fixup (Tree, Z);
283 pragma Assert (Left (Z) = null);
284 pragma Assert (Right (Z) = null);
286 if Z = Tree.Root then
287 pragma Assert (Tree.Length = 1);
288 pragma Assert (Parent (Z) = null);
290 elsif Z = Left (Parent (Z)) then
291 Set_Left (Parent (Z), null);
293 pragma Assert (Z = Right (Parent (Z)));
294 Set_Right (Parent (Z), null);
298 pragma Assert (Z /= Tree.Last);
302 if Z = Tree.First then
303 Tree.First := Min (X);
306 if Z = Tree.Root then
308 elsif Z = Left (Parent (Z)) then
309 Set_Left (Parent (Z), X);
311 pragma Assert (Z = Right (Parent (Z)));
312 Set_Right (Parent (Z), X);
315 Set_Parent (X, Parent (Z));
317 if Color (Z) = Black then
318 Delete_Fixup (Tree, X);
322 elsif Right (Z) = null then
323 pragma Assert (Z /= Tree.First);
327 if Z = Tree.Last then
328 Tree.Last := Max (X);
331 if Z = Tree.Root then
333 elsif Z = Left (Parent (Z)) then
334 Set_Left (Parent (Z), X);
336 pragma Assert (Z = Right (Parent (Z)));
337 Set_Right (Parent (Z), X);
340 Set_Parent (X, Parent (Z));
342 if Color (Z) = Black then
343 Delete_Fixup (Tree, X);
347 pragma Assert (Z /= Tree.First);
348 pragma Assert (Z /= Tree.Last);
351 pragma Assert (Left (Y) = null);
356 if Y = Left (Parent (Y)) then
357 pragma Assert (Parent (Y) /= Z);
358 Delete_Swap (Tree, Z, Y);
359 Set_Left (Parent (Z), Z);
362 pragma Assert (Y = Right (Parent (Y)));
363 pragma Assert (Parent (Y) = Z);
364 Set_Parent (Y, Parent (Z));
366 if Z = Tree.Root then
368 elsif Z = Left (Parent (Z)) then
369 Set_Left (Parent (Z), Y);
371 pragma Assert (Z = Right (Parent (Z)));
372 Set_Right (Parent (Z), Y);
375 Set_Left (Y, Left (Z));
376 Set_Parent (Left (Y), Y);
383 Y_Color : constant Color_Type := Color (Y);
385 Set_Color (Y, Color (Z));
386 Set_Color (Z, Y_Color);
390 if Color (Z) = Black then
391 Delete_Fixup (Tree, Z);
394 pragma Assert (Left (Z) = null);
395 pragma Assert (Right (Z) = null);
397 if Z = Right (Parent (Z)) then
398 Set_Right (Parent (Z), null);
400 pragma Assert (Z = Left (Parent (Z)));
401 Set_Left (Parent (Z), null);
405 if Y = Left (Parent (Y)) then
406 pragma Assert (Parent (Y) /= Z);
408 Delete_Swap (Tree, Z, Y);
410 Set_Left (Parent (Z), X);
411 Set_Parent (X, Parent (Z));
414 pragma Assert (Y = Right (Parent (Y)));
415 pragma Assert (Parent (Y) = Z);
417 Set_Parent (Y, Parent (Z));
419 if Z = Tree.Root then
421 elsif Z = Left (Parent (Z)) then
422 Set_Left (Parent (Z), Y);
424 pragma Assert (Z = Right (Parent (Z)));
425 Set_Right (Parent (Z), Y);
428 Set_Left (Y, Left (Z));
429 Set_Parent (Left (Y), Y);
432 Y_Color : constant Color_Type := Color (Y);
434 Set_Color (Y, Color (Z));
435 Set_Color (Z, Y_Color);
439 if Color (Z) = Black then
440 Delete_Fixup (Tree, X);
445 Tree.Length := Tree.Length - 1;
446 end Delete_Node_Sans_Free;
452 procedure Delete_Swap
453 (Tree : in out Tree_Type;
456 pragma Assert (Z /= Y);
457 pragma Assert (Parent (Y) /= Z);
459 Y_Parent : constant Node_Access := Parent (Y);
460 Y_Color : constant Color_Type := Color (Y);
463 Set_Parent (Y, Parent (Z));
464 Set_Left (Y, Left (Z));
465 Set_Right (Y, Right (Z));
466 Set_Color (Y, Color (Z));
468 if Tree.Root = Z then
470 elsif Right (Parent (Y)) = Z then
471 Set_Right (Parent (Y), Y);
473 pragma Assert (Left (Parent (Y)) = Z);
474 Set_Left (Parent (Y), Y);
477 if Right (Y) /= null then
478 Set_Parent (Right (Y), Y);
481 if Left (Y) /= null then
482 Set_Parent (Left (Y), Y);
485 Set_Parent (Z, Y_Parent);
486 Set_Color (Z, Y_Color);
495 procedure Generic_Adjust (Tree : in out Tree_Type) is
496 N : constant Count_Type := Tree.Length;
497 Root : constant Node_Access := Tree.Root;
501 pragma Assert (Root = null);
502 pragma Assert (Tree.Busy = 0);
503 pragma Assert (Tree.Lock = 0);
512 Tree.Root := Copy_Tree (Root);
513 Tree.First := Min (Tree.Root);
514 Tree.Last := Max (Tree.Root);
522 procedure Generic_Clear (Tree : in out Tree_Type) is
523 Root : Node_Access := Tree.Root;
525 if Tree.Busy > 0 then
529 Tree := (First => null,
539 -----------------------
540 -- Generic_Copy_Tree --
541 -----------------------
543 function Generic_Copy_Tree (Source_Root : Node_Access) return Node_Access is
544 Target_Root : Node_Access := Copy_Node (Source_Root);
548 if Right (Source_Root) /= null then
550 (Node => Target_Root,
551 Right => Generic_Copy_Tree (Right (Source_Root)));
554 (Node => Right (Target_Root),
555 Parent => Target_Root);
560 X := Left (Source_Root);
563 Y : constant Node_Access := Copy_Node (X);
565 Set_Left (Node => P, Left => Y);
566 Set_Parent (Node => Y, Parent => P);
568 if Right (X) /= null then
571 Right => Generic_Copy_Tree (Right (X)));
586 Delete_Tree (Target_Root);
588 end Generic_Copy_Tree;
590 -------------------------
591 -- Generic_Delete_Tree --
592 -------------------------
594 procedure Generic_Delete_Tree (X : in out Node_Access) is
599 Generic_Delete_Tree (Y);
604 end Generic_Delete_Tree;
610 function Generic_Equal (Left, Right : Tree_Type) return Boolean is
611 L_Node : Node_Access;
612 R_Node : Node_Access;
615 if Left'Address = Right'Address then
619 if Left.Length /= Right.Length then
623 L_Node := Left.First;
624 R_Node := Right.First;
625 while L_Node /= null loop
626 if not Is_Equal (L_Node, R_Node) then
630 L_Node := Next (L_Node);
631 R_Node := Next (R_Node);
637 -----------------------
638 -- Generic_Iteration --
639 -----------------------
641 procedure Generic_Iteration (Tree : Tree_Type) is
642 procedure Iterate (P : Node_Access);
648 procedure Iterate (P : Node_Access) is
649 X : Node_Access := P;
658 -- Start of processing for Generic_Iteration
662 end Generic_Iteration;
668 procedure Generic_Move (Target, Source : in out Tree_Type) is
670 if Target'Address = Source'Address then
674 if Source.Busy > 0 then
682 Source := (First => null,
694 procedure Generic_Read
695 (Stream : access Root_Stream_Type'Class;
696 Tree : in out Tree_Type)
700 Node, Last_Node : Node_Access;
705 Count_Type'Base'Read (Stream, N);
706 pragma Assert (N >= 0);
712 Node := Read_Node (Stream);
713 pragma Assert (Node /= null);
714 pragma Assert (Color (Node) = Red);
716 Set_Color (Node, Black);
724 for J in Count_Type range 2 .. N loop
726 pragma Assert (Last_Node = Tree.Last);
728 Node := Read_Node (Stream);
729 pragma Assert (Node /= null);
730 pragma Assert (Color (Node) = Red);
732 Set_Right (Node => Last_Node, Right => Node);
734 Set_Parent (Node => Node, Parent => Last_Node);
735 Rebalance_For_Insert (Tree, Node);
736 Tree.Length := Tree.Length + 1;
740 -------------------------------
741 -- Generic_Reverse_Iteration --
742 -------------------------------
744 procedure Generic_Reverse_Iteration (Tree : Tree_Type)
746 procedure Iterate (P : Node_Access);
752 procedure Iterate (P : Node_Access) is
753 X : Node_Access := P;
762 -- Start of processing for Generic_Reverse_Iteration
766 end Generic_Reverse_Iteration;
772 procedure Generic_Write
773 (Stream : access Root_Stream_Type'Class;
776 procedure Process (Node : Node_Access);
777 pragma Inline (Process);
780 new Generic_Iteration (Process);
786 procedure Process (Node : Node_Access) is
788 Write_Node (Stream, Node);
791 -- Start of processing for Generic_Write
794 Count_Type'Base'Write (Stream, Tree.Length);
802 procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access) is
806 Y : constant Node_Access := Right (X);
807 pragma Assert (Y /= null);
810 Set_Right (X, Left (Y));
812 if Left (Y) /= null then
813 Set_Parent (Left (Y), X);
816 Set_Parent (Y, Parent (X));
818 if X = Tree.Root then
820 elsif X = Left (Parent (X)) then
821 Set_Left (Parent (X), Y);
823 pragma Assert (X = Right (Parent (X)));
824 Set_Right (Parent (X), Y);
835 function Max (Node : Node_Access) return Node_Access is
839 X : Node_Access := Node;
858 function Min (Node : Node_Access) return Node_Access is
862 X : Node_Access := Node;
881 function Next (Node : Node_Access) return Node_Access is
889 if Right (Node) /= null then
890 return Min (Right (Node));
894 X : Node_Access := Node;
895 Y : Node_Access := Parent (Node);
899 and then X = Right (Y)
905 -- Why is this code commented out ???
907 -- if Right (X) /= Y then
921 function Previous (Node : Node_Access) return Node_Access is
927 if Left (Node) /= null then
928 return Max (Left (Node));
932 X : Node_Access := Node;
933 Y : Node_Access := Parent (Node);
937 and then X = Left (Y)
943 -- Why is this code commented out ???
945 -- if Left (X) /= Y then
955 --------------------------
956 -- Rebalance_For_Insert --
957 --------------------------
959 procedure Rebalance_For_Insert
960 (Tree : in out Tree_Type;
965 X : Node_Access := Node;
966 pragma Assert (X /= null);
967 pragma Assert (Color (X) = Red);
972 while X /= Tree.Root and then Color (Parent (X)) = Red loop
973 if Parent (X) = Left (Parent (Parent (X))) then
974 Y := Right (Parent (Parent (X)));
976 if Y /= null and then Color (Y) = Red then
977 Set_Color (Parent (X), Black);
978 Set_Color (Y, Black);
979 Set_Color (Parent (Parent (X)), Red);
980 X := Parent (Parent (X));
983 if X = Right (Parent (X)) then
985 Left_Rotate (Tree, X);
988 Set_Color (Parent (X), Black);
989 Set_Color (Parent (Parent (X)), Red);
990 Right_Rotate (Tree, Parent (Parent (X)));
994 pragma Assert (Parent (X) = Right (Parent (Parent (X))));
996 Y := Left (Parent (Parent (X)));
998 if Y /= null and then Color (Y) = Red then
999 Set_Color (Parent (X), Black);
1000 Set_Color (Y, Black);
1001 Set_Color (Parent (Parent (X)), Red);
1002 X := Parent (Parent (X));
1005 if X = Left (Parent (X)) then
1007 Right_Rotate (Tree, X);
1010 Set_Color (Parent (X), Black);
1011 Set_Color (Parent (Parent (X)), Red);
1012 Left_Rotate (Tree, Parent (Parent (X)));
1017 Set_Color (Tree.Root, Black);
1018 end Rebalance_For_Insert;
1024 procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access) is
1025 X : constant Node_Access := Left (Y);
1026 pragma Assert (X /= null);
1029 Set_Left (Y, Right (X));
1031 if Right (X) /= null then
1032 Set_Parent (Right (X), Y);
1035 Set_Parent (X, Parent (Y));
1037 if Y = Tree.Root then
1039 elsif Y = Left (Parent (Y)) then
1040 Set_Left (Parent (Y), X);
1042 pragma Assert (Y = Right (Parent (Y)));
1043 Set_Right (Parent (Y), X);
1054 function Vet (Tree : Tree_Type; Node : Node_Access) return Boolean is
1060 if Parent (Node) = Node
1061 or else Left (Node) = Node
1062 or else Right (Node) = Node
1068 or else Tree.Root = null
1069 or else Tree.First = null
1070 or else Tree.Last = null
1075 if Parent (Tree.Root) /= null then
1079 if Left (Tree.First) /= null then
1083 if Right (Tree.Last) /= null then
1087 if Tree.Length = 1 then
1088 if Tree.First /= Tree.Last
1089 or else Tree.First /= Tree.Root
1094 if Node /= Tree.First then
1098 if Parent (Node) /= null
1099 or else Left (Node) /= null
1100 or else Right (Node) /= null
1108 if Tree.First = Tree.Last then
1112 if Tree.Length = 2 then
1113 if Tree.First /= Tree.Root
1114 and then Tree.Last /= Tree.Root
1119 if Tree.First /= Node
1120 and then Tree.Last /= Node
1126 if Left (Node) /= null
1127 and then Parent (Left (Node)) /= Node
1132 if Right (Node) /= null
1133 and then Parent (Right (Node)) /= Node
1138 if Parent (Node) = null then
1139 if Tree.Root /= Node then
1143 elsif Left (Parent (Node)) /= Node
1144 and then Right (Parent (Node)) /= Node
1152 end Ada.Containers.Red_Black_Trees.Generic_Operations;