1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_OPERATIONS --
9 -- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
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. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
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/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
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)
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 -- Why is all the following code commented out ???
54 -- ---------------------
55 -- -- Check_Invariant --
56 -- ---------------------
58 -- procedure Check_Invariant (Tree : Tree_Type) is
59 -- Root : constant Node_Access := Tree.Root;
61 -- function Check (Node : Node_Access) return Natural;
67 -- function Check (Node : Node_Access) return Natural is
69 -- if Node = null then
73 -- if Color (Node) = Red then
75 -- L : constant Node_Access := Left (Node);
77 -- pragma Assert (L = null or else Color (L) = Black);
82 -- R : constant Node_Access := Right (Node);
84 -- pragma Assert (R = null or else Color (R) = Black);
89 -- NL : constant Natural := Check (Left (Node));
90 -- NR : constant Natural := Check (Right (Node));
92 -- pragma Assert (NL = NR);
98 -- NL : constant Natural := Check (Left (Node));
99 -- NR : constant Natural := Check (Right (Node));
101 -- pragma Assert (NL = NR);
106 -- -- Start of processing for Check_Invariant
109 -- if Root = null then
110 -- pragma Assert (Tree.First = null);
111 -- pragma Assert (Tree.Last = null);
112 -- pragma Assert (Tree.Length = 0);
116 -- pragma Assert (Color (Root) = Black);
117 -- pragma Assert (Tree.Length > 0);
118 -- pragma Assert (Tree.Root /= null);
119 -- pragma Assert (Tree.First /= null);
120 -- pragma Assert (Tree.Last /= null);
121 -- pragma Assert (Parent (Tree.Root) = null);
122 -- pragma Assert ((Tree.Length > 1)
123 -- or else (Tree.First = Tree.Last
124 -- and Tree.First = Tree.Root));
125 -- pragma Assert (Left (Tree.First) = null);
126 -- pragma Assert (Right (Tree.Last) = null);
129 -- L : constant Node_Access := Left (Root);
130 -- R : constant Node_Access := Right (Root);
131 -- NL : constant Natural := Check (L);
132 -- NR : constant Natural := Check (R);
134 -- pragma Assert (NL = NR);
138 -- end Check_Invariant;
144 procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access) is
148 X : Node_Access := Node;
153 and then Color (X) = Black
155 if X = Left (Parent (X)) then
156 W := Right (Parent (X));
158 if Color (W) = Red then
159 Set_Color (W, Black);
160 Set_Color (Parent (X), Red);
161 Left_Rotate (Tree, Parent (X));
162 W := Right (Parent (X));
165 if (Left (W) = null or else Color (Left (W)) = Black)
167 (Right (W) = null or else Color (Right (W)) = Black)
174 or else Color (Right (W)) = Black
176 -- As a condition for setting the color of the left child to
177 -- black, the left child access value must be non-null. A
178 -- truth table analysis shows that if we arrive here, that
179 -- condition holds, so there's no need for an explicit test.
180 -- The assertion is here to document what we know is true.
182 pragma Assert (Left (W) /= null);
183 Set_Color (Left (W), Black);
186 Right_Rotate (Tree, W);
187 W := Right (Parent (X));
190 Set_Color (W, Color (Parent (X)));
191 Set_Color (Parent (X), Black);
192 Set_Color (Right (W), Black);
193 Left_Rotate (Tree, Parent (X));
198 pragma Assert (X = Right (Parent (X)));
200 W := Left (Parent (X));
202 if Color (W) = Red then
203 Set_Color (W, Black);
204 Set_Color (Parent (X), Red);
205 Right_Rotate (Tree, Parent (X));
206 W := Left (Parent (X));
209 if (Left (W) = null or else Color (Left (W)) = Black)
211 (Right (W) = null or else Color (Right (W)) = Black)
217 if Left (W) = null or else Color (Left (W)) = Black then
219 -- As a condition for setting the color of the right child
220 -- to black, the right child access value must be non-null.
221 -- A truth table analysis shows that if we arrive here, that
222 -- condition holds, so there's no need for an explicit test.
223 -- The assertion is here to document what we know is true.
225 pragma Assert (Right (W) /= null);
226 Set_Color (Right (W), Black);
229 Left_Rotate (Tree, W);
230 W := Left (Parent (X));
233 Set_Color (W, Color (Parent (X)));
234 Set_Color (Parent (X), Black);
235 Set_Color (Left (W), Black);
236 Right_Rotate (Tree, Parent (X));
242 Set_Color (X, Black);
245 ---------------------------
246 -- Delete_Node_Sans_Free --
247 ---------------------------
249 procedure Delete_Node_Sans_Free
250 (Tree : in out Tree_Type;
257 Z : constant Node_Access := Node;
258 pragma Assert (Z /= null);
261 if Tree.Busy > 0 then
262 raise Program_Error with
263 "attempt to tamper with cursors (container is busy)";
266 -- Why are these all commented out ???
268 -- pragma Assert (Tree.Length > 0);
269 -- pragma Assert (Tree.Root /= null);
270 -- pragma Assert (Tree.First /= null);
271 -- pragma Assert (Tree.Last /= null);
272 -- pragma Assert (Parent (Tree.Root) = null);
273 -- pragma Assert ((Tree.Length > 1)
274 -- or else (Tree.First = Tree.Last
275 -- and then Tree.First = Tree.Root));
276 -- pragma Assert ((Left (Node) = null)
277 -- or else (Parent (Left (Node)) = Node));
278 -- pragma Assert ((Right (Node) = null)
279 -- or else (Parent (Right (Node)) = Node));
280 -- pragma Assert (((Parent (Node) = null) and then (Tree.Root = Node))
281 -- or else ((Parent (Node) /= null) and then
282 -- ((Left (Parent (Node)) = Node)
283 -- or else (Right (Parent (Node)) = Node))));
285 if Left (Z) = null then
286 if Right (Z) = null then
287 if Z = Tree.First then
288 Tree.First := Parent (Z);
291 if Z = Tree.Last then
292 Tree.Last := Parent (Z);
295 if Color (Z) = Black then
296 Delete_Fixup (Tree, Z);
299 pragma Assert (Left (Z) = null);
300 pragma Assert (Right (Z) = null);
302 if Z = Tree.Root then
303 pragma Assert (Tree.Length = 1);
304 pragma Assert (Parent (Z) = null);
306 elsif Z = Left (Parent (Z)) then
307 Set_Left (Parent (Z), null);
309 pragma Assert (Z = Right (Parent (Z)));
310 Set_Right (Parent (Z), null);
314 pragma Assert (Z /= Tree.Last);
318 if Z = Tree.First then
319 Tree.First := Min (X);
322 if Z = Tree.Root then
324 elsif Z = Left (Parent (Z)) then
325 Set_Left (Parent (Z), X);
327 pragma Assert (Z = Right (Parent (Z)));
328 Set_Right (Parent (Z), X);
331 Set_Parent (X, Parent (Z));
333 if Color (Z) = Black then
334 Delete_Fixup (Tree, X);
338 elsif Right (Z) = null then
339 pragma Assert (Z /= Tree.First);
343 if Z = Tree.Last then
344 Tree.Last := Max (X);
347 if Z = Tree.Root then
349 elsif Z = Left (Parent (Z)) then
350 Set_Left (Parent (Z), X);
352 pragma Assert (Z = Right (Parent (Z)));
353 Set_Right (Parent (Z), X);
356 Set_Parent (X, Parent (Z));
358 if Color (Z) = Black then
359 Delete_Fixup (Tree, X);
363 pragma Assert (Z /= Tree.First);
364 pragma Assert (Z /= Tree.Last);
367 pragma Assert (Left (Y) = null);
372 if Y = Left (Parent (Y)) then
373 pragma Assert (Parent (Y) /= Z);
374 Delete_Swap (Tree, Z, Y);
375 Set_Left (Parent (Z), Z);
378 pragma Assert (Y = Right (Parent (Y)));
379 pragma Assert (Parent (Y) = Z);
380 Set_Parent (Y, Parent (Z));
382 if Z = Tree.Root then
384 elsif Z = Left (Parent (Z)) then
385 Set_Left (Parent (Z), Y);
387 pragma Assert (Z = Right (Parent (Z)));
388 Set_Right (Parent (Z), Y);
391 Set_Left (Y, Left (Z));
392 Set_Parent (Left (Y), Y);
399 Y_Color : constant Color_Type := Color (Y);
401 Set_Color (Y, Color (Z));
402 Set_Color (Z, Y_Color);
406 if Color (Z) = Black then
407 Delete_Fixup (Tree, Z);
410 pragma Assert (Left (Z) = null);
411 pragma Assert (Right (Z) = null);
413 if Z = Right (Parent (Z)) then
414 Set_Right (Parent (Z), null);
416 pragma Assert (Z = Left (Parent (Z)));
417 Set_Left (Parent (Z), null);
421 if Y = Left (Parent (Y)) then
422 pragma Assert (Parent (Y) /= Z);
424 Delete_Swap (Tree, Z, Y);
426 Set_Left (Parent (Z), X);
427 Set_Parent (X, Parent (Z));
430 pragma Assert (Y = Right (Parent (Y)));
431 pragma Assert (Parent (Y) = Z);
433 Set_Parent (Y, Parent (Z));
435 if Z = Tree.Root then
437 elsif Z = Left (Parent (Z)) then
438 Set_Left (Parent (Z), Y);
440 pragma Assert (Z = Right (Parent (Z)));
441 Set_Right (Parent (Z), Y);
444 Set_Left (Y, Left (Z));
445 Set_Parent (Left (Y), Y);
448 Y_Color : constant Color_Type := Color (Y);
450 Set_Color (Y, Color (Z));
451 Set_Color (Z, Y_Color);
455 if Color (Z) = Black then
456 Delete_Fixup (Tree, X);
461 Tree.Length := Tree.Length - 1;
462 end Delete_Node_Sans_Free;
468 procedure Delete_Swap
469 (Tree : in out Tree_Type;
472 pragma Assert (Z /= Y);
473 pragma Assert (Parent (Y) /= Z);
475 Y_Parent : constant Node_Access := Parent (Y);
476 Y_Color : constant Color_Type := Color (Y);
479 Set_Parent (Y, Parent (Z));
480 Set_Left (Y, Left (Z));
481 Set_Right (Y, Right (Z));
482 Set_Color (Y, Color (Z));
484 if Tree.Root = Z then
486 elsif Right (Parent (Y)) = Z then
487 Set_Right (Parent (Y), Y);
489 pragma Assert (Left (Parent (Y)) = Z);
490 Set_Left (Parent (Y), Y);
493 if Right (Y) /= null then
494 Set_Parent (Right (Y), Y);
497 if Left (Y) /= null then
498 Set_Parent (Left (Y), Y);
501 Set_Parent (Z, Y_Parent);
502 Set_Color (Z, Y_Color);
511 procedure Generic_Adjust (Tree : in out Tree_Type) is
512 N : constant Count_Type := Tree.Length;
513 Root : constant Node_Access := Tree.Root;
517 pragma Assert (Root = null);
518 pragma Assert (Tree.Busy = 0);
519 pragma Assert (Tree.Lock = 0);
528 Tree.Root := Copy_Tree (Root);
529 Tree.First := Min (Tree.Root);
530 Tree.Last := Max (Tree.Root);
538 procedure Generic_Clear (Tree : in out Tree_Type) is
539 Root : Node_Access := Tree.Root;
541 if Tree.Busy > 0 then
542 raise Program_Error with
543 "attempt to tamper with cursors (container is busy)";
546 Tree := (First => null,
556 -----------------------
557 -- Generic_Copy_Tree --
558 -----------------------
560 function Generic_Copy_Tree (Source_Root : Node_Access) return Node_Access is
561 Target_Root : Node_Access := Copy_Node (Source_Root);
565 if Right (Source_Root) /= null then
567 (Node => Target_Root,
568 Right => Generic_Copy_Tree (Right (Source_Root)));
571 (Node => Right (Target_Root),
572 Parent => Target_Root);
577 X := Left (Source_Root);
580 Y : constant Node_Access := Copy_Node (X);
582 Set_Left (Node => P, Left => Y);
583 Set_Parent (Node => Y, Parent => P);
585 if Right (X) /= null then
588 Right => Generic_Copy_Tree (Right (X)));
604 Delete_Tree (Target_Root);
606 end Generic_Copy_Tree;
608 -------------------------
609 -- Generic_Delete_Tree --
610 -------------------------
612 procedure Generic_Delete_Tree (X : in out Node_Access) is
614 pragma Warnings (Off, Y);
618 Generic_Delete_Tree (Y);
623 end Generic_Delete_Tree;
629 function Generic_Equal (Left, Right : Tree_Type) return Boolean is
630 BL : Natural renames Left'Unrestricted_Access.Busy;
631 LL : Natural renames Left'Unrestricted_Access.Lock;
633 BR : Natural renames Right'Unrestricted_Access.Busy;
634 LR : Natural renames Right'Unrestricted_Access.Lock;
636 L_Node : Node_Access;
637 R_Node : Node_Access;
642 if Left'Address = Right'Address then
646 if Left.Length /= Right.Length then
650 -- If the containers are empty, return a result immediately, so as to
651 -- not manipulate the tamper bits unnecessarily.
653 if Left.Length = 0 then
657 -- Per AI05-0022, the container implementation is required to detect
658 -- element tampering by a generic actual subprogram.
666 L_Node := Left.First;
667 R_Node := Right.First;
669 while L_Node /= null loop
670 if not Is_Equal (L_Node, R_Node) then
675 L_Node := Next (L_Node);
676 R_Node := Next (R_Node);
698 -----------------------
699 -- Generic_Iteration --
700 -----------------------
702 procedure Generic_Iteration (Tree : Tree_Type) is
703 procedure Iterate (P : Node_Access);
709 procedure Iterate (P : Node_Access) is
710 X : Node_Access := P;
719 -- Start of processing for Generic_Iteration
723 end Generic_Iteration;
729 procedure Generic_Move (Target, Source : in out Tree_Type) is
731 if Target'Address = Source'Address then
735 if Source.Busy > 0 then
736 raise Program_Error with
737 "attempt to tamper with cursors (container is busy)";
744 Source := (First => null,
756 procedure Generic_Read
757 (Stream : not null access Root_Stream_Type'Class;
758 Tree : in out Tree_Type)
762 Node, Last_Node : Node_Access;
767 Count_Type'Base'Read (Stream, N);
768 pragma Assert (N >= 0);
774 Node := Read_Node (Stream);
775 pragma Assert (Node /= null);
776 pragma Assert (Color (Node) = Red);
778 Set_Color (Node, Black);
786 for J in Count_Type range 2 .. N loop
788 pragma Assert (Last_Node = Tree.Last);
790 Node := Read_Node (Stream);
791 pragma Assert (Node /= null);
792 pragma Assert (Color (Node) = Red);
794 Set_Right (Node => Last_Node, Right => Node);
796 Set_Parent (Node => Node, Parent => Last_Node);
797 Rebalance_For_Insert (Tree, Node);
798 Tree.Length := Tree.Length + 1;
802 -------------------------------
803 -- Generic_Reverse_Iteration --
804 -------------------------------
806 procedure Generic_Reverse_Iteration (Tree : Tree_Type)
808 procedure Iterate (P : Node_Access);
814 procedure Iterate (P : Node_Access) is
815 X : Node_Access := P;
824 -- Start of processing for Generic_Reverse_Iteration
828 end Generic_Reverse_Iteration;
834 procedure Generic_Write
835 (Stream : not null access Root_Stream_Type'Class;
838 procedure Process (Node : Node_Access);
839 pragma Inline (Process);
842 new Generic_Iteration (Process);
848 procedure Process (Node : Node_Access) is
850 Write_Node (Stream, Node);
853 -- Start of processing for Generic_Write
856 Count_Type'Base'Write (Stream, Tree.Length);
864 procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access) is
868 Y : constant Node_Access := Right (X);
869 pragma Assert (Y /= null);
872 Set_Right (X, Left (Y));
874 if Left (Y) /= null then
875 Set_Parent (Left (Y), X);
878 Set_Parent (Y, Parent (X));
880 if X = Tree.Root then
882 elsif X = Left (Parent (X)) then
883 Set_Left (Parent (X), Y);
885 pragma Assert (X = Right (Parent (X)));
886 Set_Right (Parent (X), Y);
897 function Max (Node : Node_Access) return Node_Access is
901 X : Node_Access := Node;
920 function Min (Node : Node_Access) return Node_Access is
924 X : Node_Access := Node;
943 function Next (Node : Node_Access) return Node_Access is
951 if Right (Node) /= null then
952 return Min (Right (Node));
956 X : Node_Access := Node;
957 Y : Node_Access := Parent (Node);
961 and then X = Right (Y)
975 function Previous (Node : Node_Access) return Node_Access is
981 if Left (Node) /= null then
982 return Max (Left (Node));
986 X : Node_Access := Node;
987 Y : Node_Access := Parent (Node);
991 and then X = Left (Y)
1001 --------------------------
1002 -- Rebalance_For_Insert --
1003 --------------------------
1005 procedure Rebalance_For_Insert
1006 (Tree : in out Tree_Type;
1011 X : Node_Access := Node;
1012 pragma Assert (X /= null);
1013 pragma Assert (Color (X) = Red);
1018 while X /= Tree.Root and then Color (Parent (X)) = Red loop
1019 if Parent (X) = Left (Parent (Parent (X))) then
1020 Y := Right (Parent (Parent (X)));
1022 if Y /= null and then Color (Y) = Red then
1023 Set_Color (Parent (X), Black);
1024 Set_Color (Y, Black);
1025 Set_Color (Parent (Parent (X)), Red);
1026 X := Parent (Parent (X));
1029 if X = Right (Parent (X)) then
1031 Left_Rotate (Tree, X);
1034 Set_Color (Parent (X), Black);
1035 Set_Color (Parent (Parent (X)), Red);
1036 Right_Rotate (Tree, Parent (Parent (X)));
1040 pragma Assert (Parent (X) = Right (Parent (Parent (X))));
1042 Y := Left (Parent (Parent (X)));
1044 if Y /= null and then Color (Y) = Red then
1045 Set_Color (Parent (X), Black);
1046 Set_Color (Y, Black);
1047 Set_Color (Parent (Parent (X)), Red);
1048 X := Parent (Parent (X));
1051 if X = Left (Parent (X)) then
1053 Right_Rotate (Tree, X);
1056 Set_Color (Parent (X), Black);
1057 Set_Color (Parent (Parent (X)), Red);
1058 Left_Rotate (Tree, Parent (Parent (X)));
1063 Set_Color (Tree.Root, Black);
1064 end Rebalance_For_Insert;
1070 procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access) is
1071 X : constant Node_Access := Left (Y);
1072 pragma Assert (X /= null);
1075 Set_Left (Y, Right (X));
1077 if Right (X) /= null then
1078 Set_Parent (Right (X), Y);
1081 Set_Parent (X, Parent (Y));
1083 if Y = Tree.Root then
1085 elsif Y = Left (Parent (Y)) then
1086 Set_Left (Parent (Y), X);
1088 pragma Assert (Y = Right (Parent (Y)));
1089 Set_Right (Parent (Y), X);
1100 function Vet (Tree : Tree_Type; Node : Node_Access) return Boolean is
1106 if Parent (Node) = Node
1107 or else Left (Node) = Node
1108 or else Right (Node) = Node
1114 or else Tree.Root = null
1115 or else Tree.First = null
1116 or else Tree.Last = null
1121 if Parent (Tree.Root) /= null then
1125 if Left (Tree.First) /= null then
1129 if Right (Tree.Last) /= null then
1133 if Tree.Length = 1 then
1134 if Tree.First /= Tree.Last
1135 or else Tree.First /= Tree.Root
1140 if Node /= Tree.First then
1144 if Parent (Node) /= null
1145 or else Left (Node) /= null
1146 or else Right (Node) /= null
1154 if Tree.First = Tree.Last then
1158 if Tree.Length = 2 then
1159 if Tree.First /= Tree.Root
1160 and then Tree.Last /= Tree.Root
1165 if Tree.First /= Node
1166 and then Tree.Last /= Node
1172 if Left (Node) /= null
1173 and then Parent (Left (Node)) /= Node
1178 if Right (Node) /= null
1179 and then Parent (Right (Node)) /= Node
1184 if Parent (Node) = null then
1185 if Tree.Root /= Node then
1189 elsif Left (Parent (Node)) /= Node
1190 and then Right (Parent (Node)) /= Node
1198 end Ada.Containers.Red_Black_Trees.Generic_Operations;