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
);
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
;