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, 59 Temple Place - Suite 330, Boston, --
25 -- MA 02111-1307, 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);
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
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
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);
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);
549 if Right (Source_Root) /= null then
551 (Node => Target_Root,
552 Right => Generic_Copy_Tree (Right (Source_Root)));
555 (Node => Right (Target_Root),
556 Parent => Target_Root);
561 X := Left (Source_Root);
564 Y : constant Node_Access := Copy_Node (X);
566 Set_Left (Node => P, Left => Y);
567 Set_Parent (Node => Y, Parent => P);
569 if Right (X) /= null then
572 Right => Generic_Copy_Tree (Right (X)));
587 Delete_Tree (Target_Root);
590 end Generic_Copy_Tree;
592 -------------------------
593 -- Generic_Delete_Tree --
594 -------------------------
596 procedure Generic_Delete_Tree (X : in out Node_Access) is
601 Generic_Delete_Tree (Y);
606 end Generic_Delete_Tree;
612 function Generic_Equal (Left, Right : Tree_Type) return Boolean is
613 L_Node : Node_Access;
614 R_Node : Node_Access;
617 if Left'Address = Right'Address then
621 if Left.Length /= Right.Length then
625 L_Node := Left.First;
626 R_Node := Right.First;
627 while L_Node /= null loop
628 if not Is_Equal (L_Node, R_Node) then
632 L_Node := Next (L_Node);
633 R_Node := Next (R_Node);
639 -----------------------
640 -- Generic_Iteration --
641 -----------------------
643 procedure Generic_Iteration (Tree : Tree_Type) is
644 procedure Iterate (P : Node_Access);
650 procedure Iterate (P : Node_Access) is
651 X : Node_Access := P;
660 -- Start of processing for Generic_Iteration
664 end Generic_Iteration;
670 procedure Generic_Move (Target, Source : in out Tree_Type) is
672 if Target'Address = Source'Address then
676 if Source.Busy > 0 then
684 Source := (First => null,
696 procedure Generic_Read
697 (Stream : access Root_Stream_Type'Class;
698 Tree : in out Tree_Type)
702 Node, Last_Node : Node_Access;
707 Count_Type'Base'Read (Stream, N);
708 pragma Assert (N >= 0);
714 Node := Read_Node (Stream);
715 pragma Assert (Node /= null);
716 pragma Assert (Color (Node) = Red);
718 Set_Color (Node, Black);
726 for J in Count_Type range 2 .. N loop
728 pragma Assert (Last_Node = Tree.Last);
730 Node := Read_Node (Stream);
731 pragma Assert (Node /= null);
732 pragma Assert (Color (Node) = Red);
734 Set_Right (Node => Last_Node, Right => Node);
736 Set_Parent (Node => Node, Parent => Last_Node);
737 Rebalance_For_Insert (Tree, Node);
738 Tree.Length := Tree.Length + 1;
742 -------------------------------
743 -- Generic_Reverse_Iteration --
744 -------------------------------
746 procedure Generic_Reverse_Iteration (Tree : Tree_Type)
748 procedure Iterate (P : Node_Access);
754 procedure Iterate (P : Node_Access) is
755 X : Node_Access := P;
764 -- Start of processing for Generic_Reverse_Iteration
768 end Generic_Reverse_Iteration;
774 procedure Generic_Write
775 (Stream : access Root_Stream_Type'Class;
778 procedure Process (Node : Node_Access);
779 pragma Inline (Process);
782 new Generic_Iteration (Process);
788 procedure Process (Node : Node_Access) is
790 Write_Node (Stream, Node);
793 -- Start of processing for Generic_Write
796 Count_Type'Base'Write (Stream, Tree.Length);
804 procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access) is
808 Y : constant Node_Access := Right (X);
809 pragma Assert (Y /= null);
812 Set_Right (X, Left (Y));
814 if Left (Y) /= null then
815 Set_Parent (Left (Y), X);
818 Set_Parent (Y, Parent (X));
820 if X = Tree.Root then
822 elsif X = Left (Parent (X)) then
823 Set_Left (Parent (X), Y);
825 pragma Assert (X = Right (Parent (X)));
826 Set_Right (Parent (X), Y);
837 function Max (Node : Node_Access) return Node_Access is
841 X : Node_Access := Node;
860 function Min (Node : Node_Access) return Node_Access is
864 X : Node_Access := Node;
883 function Next (Node : Node_Access) return Node_Access is
891 if Right (Node) /= null then
892 return Min (Right (Node));
896 X : Node_Access := Node;
897 Y : Node_Access := Parent (Node);
901 and then X = Right (Y)
907 -- Why is this code commented out ???
909 -- if Right (X) /= Y then
923 function Previous (Node : Node_Access) return Node_Access is
929 if Left (Node) /= null then
930 return Max (Left (Node));
934 X : Node_Access := Node;
935 Y : Node_Access := Parent (Node);
939 and then X = Left (Y)
945 -- Why is this code commented out ???
947 -- if Left (X) /= Y then
957 --------------------------
958 -- Rebalance_For_Insert --
959 --------------------------
961 procedure Rebalance_For_Insert
962 (Tree : in out Tree_Type;
967 X : Node_Access := Node;
968 pragma Assert (X /= null);
969 pragma Assert (Color (X) = Red);
974 while X /= Tree.Root and then Color (Parent (X)) = Red loop
975 if Parent (X) = Left (Parent (Parent (X))) then
976 Y := Right (Parent (Parent (X)));
978 if Y /= null and then Color (Y) = Red then
979 Set_Color (Parent (X), Black);
980 Set_Color (Y, Black);
981 Set_Color (Parent (Parent (X)), Red);
982 X := Parent (Parent (X));
985 if X = Right (Parent (X)) then
987 Left_Rotate (Tree, X);
990 Set_Color (Parent (X), Black);
991 Set_Color (Parent (Parent (X)), Red);
992 Right_Rotate (Tree, Parent (Parent (X)));
996 pragma Assert (Parent (X) = Right (Parent (Parent (X))));
998 Y := Left (Parent (Parent (X)));
1000 if Y /= null and then Color (Y) = Red then
1001 Set_Color (Parent (X), Black);
1002 Set_Color (Y, Black);
1003 Set_Color (Parent (Parent (X)), Red);
1004 X := Parent (Parent (X));
1007 if X = Left (Parent (X)) then
1009 Right_Rotate (Tree, X);
1012 Set_Color (Parent (X), Black);
1013 Set_Color (Parent (Parent (X)), Red);
1014 Left_Rotate (Tree, Parent (Parent (X)));
1019 Set_Color (Tree.Root, Black);
1020 end Rebalance_For_Insert;
1026 procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access) is
1027 X : constant Node_Access := Left (Y);
1028 pragma Assert (X /= null);
1031 Set_Left (Y, Right (X));
1033 if Right (X) /= null then
1034 Set_Parent (Right (X), Y);
1037 Set_Parent (X, Parent (Y));
1039 if Y = Tree.Root then
1041 elsif Y = Left (Parent (Y)) then
1042 Set_Left (Parent (Y), X);
1044 pragma Assert (Y = Right (Parent (Y)));
1045 Set_Right (Parent (Y), X);
1052 end Ada.Containers.Red_Black_Trees.Generic_Operations;