| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT LIBRARY COMPONENTS -- |
| -- -- |
| -- 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 . -- |
| -- G E N E R I C _ O P E R A T I O N S -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- |
| -- -- |
| -- This specification is derived from the Ada Reference Manual for use with -- |
| -- GNAT. The copyright notice above, and the license provisions that follow -- |
| -- apply solely to the contents of the part following the private keyword. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 2, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING. If not, write -- |
| -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- |
| -- Boston, MA 02110-1301, USA. -- |
| -- -- |
| -- As a special exception, if other files instantiate generics from this -- |
| -- unit, or you link this unit with other files to produce an executable, -- |
| -- this unit does not by itself cause the resulting executable to be -- |
| -- covered by the GNU General Public License. This exception does not -- |
| -- however invalidate any other reasons why the executable file might be -- |
| -- covered by the GNU Public License. -- |
| -- -- |
| -- This unit was originally developed by Matthew J Heaney. -- |
| ------------------------------------------------------------------------------ |
| |
| with System; use type System.Address; |
| |
| package body Ada.Containers.Red_Black_Trees.Generic_Operations is |
| |
| ----------------------- |
| -- Local Subprograms -- |
| ----------------------- |
| |
| procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access); |
| |
| procedure Delete_Swap (Tree : in out Tree_Type; Z, Y : Node_Access); |
| |
| procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access); |
| procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access); |
| |
| -- --------------------- |
| -- -- Check_Invariant -- |
| -- --------------------- |
| |
| -- procedure Check_Invariant (Tree : Tree_Type) is |
| -- Root : constant Node_Access := Tree.Root; |
| -- |
| -- function Check (Node : Node_Access) return Natural; |
| -- |
| -- ----------- |
| -- -- Check -- |
| -- ----------- |
| -- |
| -- function Check (Node : Node_Access) return Natural is |
| -- begin |
| -- if Node = null then |
| -- return 0; |
| -- end if; |
| -- |
| -- if Color (Node) = Red then |
| -- declare |
| -- L : constant Node_Access := Left (Node); |
| -- begin |
| -- pragma Assert (L = null or else Color (L) = Black); |
| -- null; |
| -- end; |
| -- |
| -- declare |
| -- R : constant Node_Access := Right (Node); |
| -- begin |
| -- pragma Assert (R = null or else Color (R) = Black); |
| -- null; |
| -- end; |
| -- |
| -- declare |
| -- NL : constant Natural := Check (Left (Node)); |
| -- NR : constant Natural := Check (Right (Node)); |
| -- begin |
| -- pragma Assert (NL = NR); |
| -- return NL; |
| -- end; |
| -- end if; |
| -- |
| -- declare |
| -- NL : constant Natural := Check (Left (Node)); |
| -- NR : constant Natural := Check (Right (Node)); |
| -- begin |
| -- pragma Assert (NL = NR); |
| -- return NL + 1; |
| -- end; |
| -- end Check; |
| -- |
| -- -- Start of processing for Check_Invariant |
| -- |
| -- begin |
| -- if Root = null then |
| -- pragma Assert (Tree.First = null); |
| -- pragma Assert (Tree.Last = null); |
| -- pragma Assert (Tree.Length = 0); |
| -- null; |
| -- |
| -- else |
| -- pragma Assert (Color (Root) = Black); |
| -- pragma Assert (Tree.Length > 0); |
| -- pragma Assert (Tree.Root /= null); |
| -- pragma Assert (Tree.First /= null); |
| -- pragma Assert (Tree.Last /= null); |
| -- pragma Assert (Parent (Tree.Root) = null); |
| -- pragma Assert ((Tree.Length > 1) |
| -- or else (Tree.First = Tree.Last |
| -- and Tree.First = Tree.Root)); |
| -- pragma Assert (Left (Tree.First) = null); |
| -- pragma Assert (Right (Tree.Last) = null); |
| -- |
| -- declare |
| -- L : constant Node_Access := Left (Root); |
| -- R : constant Node_Access := Right (Root); |
| -- NL : constant Natural := Check (L); |
| -- NR : constant Natural := Check (R); |
| -- begin |
| -- pragma Assert (NL = NR); |
| -- null; |
| -- end; |
| -- end if; |
| -- end Check_Invariant; |
| |
| ------------------ |
| -- Delete_Fixup -- |
| ------------------ |
| |
| procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access) is |
| |
| -- CLR p274 ??? |
| |
| X : Node_Access := Node; |
| W : Node_Access; |
| |
| begin |
| while X /= Tree.Root |
| and then Color (X) = Black |
| loop |
| if X = Left (Parent (X)) then |
| W := Right (Parent (X)); |
| |
| if Color (W) = Red then |
| Set_Color (W, Black); |
| Set_Color (Parent (X), Red); |
| Left_Rotate (Tree, Parent (X)); |
| W := Right (Parent (X)); |
| end if; |
| |
| if (Left (W) = null or else Color (Left (W)) = Black) |
| and then |
| (Right (W) = null or else Color (Right (W)) = Black) |
| then |
| Set_Color (W, Red); |
| X := Parent (X); |
| |
| else |
| if Right (W) = null |
| or else Color (Right (W)) = Black |
| then |
| if Left (W) /= null then |
| Set_Color (Left (W), Black); |
| end if; |
| |
| Set_Color (W, Red); |
| Right_Rotate (Tree, W); |
| W := Right (Parent (X)); |
| end if; |
| |
| Set_Color (W, Color (Parent (X))); |
| Set_Color (Parent (X), Black); |
| Set_Color (Right (W), Black); |
| Left_Rotate (Tree, Parent (X)); |
| X := Tree.Root; |
| end if; |
| |
| else |
| pragma Assert (X = Right (Parent (X))); |
| |
| W := Left (Parent (X)); |
| |
| if Color (W) = Red then |
| Set_Color (W, Black); |
| Set_Color (Parent (X), Red); |
| Right_Rotate (Tree, Parent (X)); |
| W := Left (Parent (X)); |
| end if; |
| |
| if (Left (W) = null or else Color (Left (W)) = Black) |
| and then |
| (Right (W) = null or else Color (Right (W)) = Black) |
| then |
| Set_Color (W, Red); |
| X := Parent (X); |
| |
| else |
| if Left (W) = null or else Color (Left (W)) = Black then |
| if Right (W) /= null then |
| Set_Color (Right (W), Black); |
| end if; |
| |
| Set_Color (W, Red); |
| Left_Rotate (Tree, W); |
| W := Left (Parent (X)); |
| end if; |
| |
| Set_Color (W, Color (Parent (X))); |
| Set_Color (Parent (X), Black); |
| Set_Color (Left (W), Black); |
| Right_Rotate (Tree, Parent (X)); |
| X := Tree.Root; |
| end if; |
| end if; |
| end loop; |
| |
| Set_Color (X, Black); |
| end Delete_Fixup; |
| |
| --------------------------- |
| -- Delete_Node_Sans_Free -- |
| --------------------------- |
| |
| procedure Delete_Node_Sans_Free |
| (Tree : in out Tree_Type; |
| Node : Node_Access) |
| is |
| -- CLR p273 ??? |
| |
| X, Y : Node_Access; |
| |
| Z : constant Node_Access := Node; |
| pragma Assert (Z /= null); |
| |
| begin |
| if Tree.Busy > 0 then |
| raise Program_Error with |
| "attempt to tamper with cursors (container is busy)"; |
| end if; |
| |
| -- pragma Assert (Tree.Length > 0); |
| -- pragma Assert (Tree.Root /= null); |
| -- pragma Assert (Tree.First /= null); |
| -- pragma Assert (Tree.Last /= null); |
| -- pragma Assert (Parent (Tree.Root) = null); |
| -- pragma Assert ((Tree.Length > 1) |
| -- or else (Tree.First = Tree.Last |
| -- and then Tree.First = Tree.Root)); |
| -- pragma Assert ((Left (Node) = null) |
| -- or else (Parent (Left (Node)) = Node)); |
| -- pragma Assert ((Right (Node) = null) |
| -- or else (Parent (Right (Node)) = Node)); |
| -- pragma Assert (((Parent (Node) = null) and then (Tree.Root = Node)) |
| -- or else ((Parent (Node) /= null) and then |
| -- ((Left (Parent (Node)) = Node) |
| -- or else (Right (Parent (Node)) = Node)))); |
| |
| if Left (Z) = null then |
| if Right (Z) = null then |
| if Z = Tree.First then |
| Tree.First := Parent (Z); |
| end if; |
| |
| if Z = Tree.Last then |
| Tree.Last := Parent (Z); |
| end if; |
| |
| if Color (Z) = Black then |
| Delete_Fixup (Tree, Z); |
| end if; |
| |
| pragma Assert (Left (Z) = null); |
| pragma Assert (Right (Z) = null); |
| |
| if Z = Tree.Root then |
| pragma Assert (Tree.Length = 1); |
| pragma Assert (Parent (Z) = null); |
| Tree.Root := null; |
| elsif Z = Left (Parent (Z)) then |
| Set_Left (Parent (Z), null); |
| else |
| pragma Assert (Z = Right (Parent (Z))); |
| Set_Right (Parent (Z), null); |
| end if; |
| |
| else |
| pragma Assert (Z /= Tree.Last); |
| |
| X := Right (Z); |
| |
| if Z = Tree.First then |
| Tree.First := Min (X); |
| end if; |
| |
| if Z = Tree.Root then |
| Tree.Root := X; |
| elsif Z = Left (Parent (Z)) then |
| Set_Left (Parent (Z), X); |
| else |
| pragma Assert (Z = Right (Parent (Z))); |
| Set_Right (Parent (Z), X); |
| end if; |
| |
| Set_Parent (X, Parent (Z)); |
| |
| if Color (Z) = Black then |
| Delete_Fixup (Tree, X); |
| end if; |
| end if; |
| |
| elsif Right (Z) = null then |
| pragma Assert (Z /= Tree.First); |
| |
| X := Left (Z); |
| |
| if Z = Tree.Last then |
| Tree.Last := Max (X); |
| end if; |
| |
| if Z = Tree.Root then |
| Tree.Root := X; |
| elsif Z = Left (Parent (Z)) then |
| Set_Left (Parent (Z), X); |
| else |
| pragma Assert (Z = Right (Parent (Z))); |
| Set_Right (Parent (Z), X); |
| end if; |
| |
| Set_Parent (X, Parent (Z)); |
| |
| if Color (Z) = Black then |
| Delete_Fixup (Tree, X); |
| end if; |
| |
| else |
| pragma Assert (Z /= Tree.First); |
| pragma Assert (Z /= Tree.Last); |
| |
| Y := Next (Z); |
| pragma Assert (Left (Y) = null); |
| |
| X := Right (Y); |
| |
| if X = null then |
| if Y = Left (Parent (Y)) then |
| pragma Assert (Parent (Y) /= Z); |
| Delete_Swap (Tree, Z, Y); |
| Set_Left (Parent (Z), Z); |
| |
| else |
| pragma Assert (Y = Right (Parent (Y))); |
| pragma Assert (Parent (Y) = Z); |
| Set_Parent (Y, Parent (Z)); |
| |
| if Z = Tree.Root then |
| Tree.Root := Y; |
| elsif Z = Left (Parent (Z)) then |
| Set_Left (Parent (Z), Y); |
| else |
| pragma Assert (Z = Right (Parent (Z))); |
| Set_Right (Parent (Z), Y); |
| end if; |
| |
| Set_Left (Y, Left (Z)); |
| Set_Parent (Left (Y), Y); |
| Set_Right (Y, Z); |
| Set_Parent (Z, Y); |
| Set_Left (Z, null); |
| Set_Right (Z, null); |
| |
| declare |
| Y_Color : constant Color_Type := Color (Y); |
| begin |
| Set_Color (Y, Color (Z)); |
| Set_Color (Z, Y_Color); |
| end; |
| end if; |
| |
| if Color (Z) = Black then |
| Delete_Fixup (Tree, Z); |
| end if; |
| |
| pragma Assert (Left (Z) = null); |
| pragma Assert (Right (Z) = null); |
| |
| if Z = Right (Parent (Z)) then |
| Set_Right (Parent (Z), null); |
| else |
| pragma Assert (Z = Left (Parent (Z))); |
| Set_Left (Parent (Z), null); |
| end if; |
| |
| else |
| if Y = Left (Parent (Y)) then |
| pragma Assert (Parent (Y) /= Z); |
| |
| Delete_Swap (Tree, Z, Y); |
| |
| Set_Left (Parent (Z), X); |
| Set_Parent (X, Parent (Z)); |
| |
| else |
| pragma Assert (Y = Right (Parent (Y))); |
| pragma Assert (Parent (Y) = Z); |
| |
| Set_Parent (Y, Parent (Z)); |
| |
| if Z = Tree.Root then |
| Tree.Root := Y; |
| elsif Z = Left (Parent (Z)) then |
| Set_Left (Parent (Z), Y); |
| else |
| pragma Assert (Z = Right (Parent (Z))); |
| Set_Right (Parent (Z), Y); |
| end if; |
| |
| Set_Left (Y, Left (Z)); |
| Set_Parent (Left (Y), Y); |
| |
| declare |
| Y_Color : constant Color_Type := Color (Y); |
| begin |
| Set_Color (Y, Color (Z)); |
| Set_Color (Z, Y_Color); |
| end; |
| end if; |
| |
| if Color (Z) = Black then |
| Delete_Fixup (Tree, X); |
| end if; |
| end if; |
| end if; |
| |
| Tree.Length := Tree.Length - 1; |
| end Delete_Node_Sans_Free; |
| |
| ----------------- |
| -- Delete_Swap -- |
| ----------------- |
| |
| procedure Delete_Swap |
| (Tree : in out Tree_Type; |
| Z, Y : Node_Access) |
| is |
| pragma Assert (Z /= Y); |
| pragma Assert (Parent (Y) /= Z); |
| |
| Y_Parent : constant Node_Access := Parent (Y); |
| Y_Color : constant Color_Type := Color (Y); |
| |
| begin |
| Set_Parent (Y, Parent (Z)); |
| Set_Left (Y, Left (Z)); |
| Set_Right (Y, Right (Z)); |
| Set_Color (Y, Color (Z)); |
| |
| if Tree.Root = Z then |
| Tree.Root := Y; |
| elsif Right (Parent (Y)) = Z then |
| Set_Right (Parent (Y), Y); |
| else |
| pragma Assert (Left (Parent (Y)) = Z); |
| Set_Left (Parent (Y), Y); |
| end if; |
| |
| if Right (Y) /= null then |
| Set_Parent (Right (Y), Y); |
| end if; |
| |
| if Left (Y) /= null then |
| Set_Parent (Left (Y), Y); |
| end if; |
| |
| Set_Parent (Z, Y_Parent); |
| Set_Color (Z, Y_Color); |
| Set_Left (Z, null); |
| Set_Right (Z, null); |
| end Delete_Swap; |
| |
| -------------------- |
| -- Generic_Adjust -- |
| -------------------- |
| |
| procedure Generic_Adjust (Tree : in out Tree_Type) is |
| N : constant Count_Type := Tree.Length; |
| Root : constant Node_Access := Tree.Root; |
| |
| begin |
| if N = 0 then |
| pragma Assert (Root = null); |
| pragma Assert (Tree.Busy = 0); |
| pragma Assert (Tree.Lock = 0); |
| return; |
| end if; |
| |
| Tree.Root := null; |
| Tree.First := null; |
| Tree.Last := null; |
| Tree.Length := 0; |
| |
| Tree.Root := Copy_Tree (Root); |
| Tree.First := Min (Tree.Root); |
| Tree.Last := Max (Tree.Root); |
| Tree.Length := N; |
| end Generic_Adjust; |
| |
| ------------------- |
| -- Generic_Clear -- |
| ------------------- |
| |
| procedure Generic_Clear (Tree : in out Tree_Type) is |
| Root : Node_Access := Tree.Root; |
| begin |
| if Tree.Busy > 0 then |
| raise Program_Error with |
| "attempt to tamper with cursors (container is busy)"; |
| end if; |
| |
| Tree := (First => null, |
| Last => null, |
| Root => null, |
| Length => 0, |
| Busy => 0, |
| Lock => 0); |
| |
| Delete_Tree (Root); |
| end Generic_Clear; |
| |
| ----------------------- |
| -- Generic_Copy_Tree -- |
| ----------------------- |
| |
| function Generic_Copy_Tree (Source_Root : Node_Access) return Node_Access is |
| Target_Root : Node_Access := Copy_Node (Source_Root); |
| P, X : Node_Access; |
| |
| begin |
| if Right (Source_Root) /= null then |
| Set_Right |
| (Node => Target_Root, |
| Right => Generic_Copy_Tree (Right (Source_Root))); |
| |
| Set_Parent |
| (Node => Right (Target_Root), |
| Parent => Target_Root); |
| end if; |
| |
| P := Target_Root; |
| |
| X := Left (Source_Root); |
| while X /= null loop |
| declare |
| Y : constant Node_Access := Copy_Node (X); |
| begin |
| Set_Left (Node => P, Left => Y); |
| Set_Parent (Node => Y, Parent => P); |
| |
| if Right (X) /= null then |
| Set_Right |
| (Node => Y, |
| Right => Generic_Copy_Tree (Right (X))); |
| |
| Set_Parent |
| (Node => Right (Y), |
| Parent => Y); |
| end if; |
| |
| P := Y; |
| X := Left (X); |
| end; |
| end loop; |
| |
| return Target_Root; |
| exception |
| when others => |
| Delete_Tree (Target_Root); |
| raise; |
| end Generic_Copy_Tree; |
| |
| ------------------------- |
| -- Generic_Delete_Tree -- |
| ------------------------- |
| |
| procedure Generic_Delete_Tree (X : in out Node_Access) is |
| Y : Node_Access; |
| begin |
| while X /= null loop |
| Y := Right (X); |
| Generic_Delete_Tree (Y); |
| Y := Left (X); |
| Free (X); |
| X := Y; |
| end loop; |
| end Generic_Delete_Tree; |
| |
| ------------------- |
| -- Generic_Equal -- |
| ------------------- |
| |
| function Generic_Equal (Left, Right : Tree_Type) return Boolean is |
| L_Node : Node_Access; |
| R_Node : Node_Access; |
| |
| begin |
| if Left'Address = Right'Address then |
| return True; |
| end if; |
| |
| if Left.Length /= Right.Length then |
| return False; |
| end if; |
| |
| L_Node := Left.First; |
| R_Node := Right.First; |
| while L_Node /= null loop |
| if not Is_Equal (L_Node, R_Node) then |
| return False; |
| end if; |
| |
| L_Node := Next (L_Node); |
| R_Node := Next (R_Node); |
| end loop; |
| |
| return True; |
| end Generic_Equal; |
| |
| ----------------------- |
| -- Generic_Iteration -- |
| ----------------------- |
| |
| procedure Generic_Iteration (Tree : Tree_Type) is |
| procedure Iterate (P : Node_Access); |
| |
| ------------- |
| -- Iterate -- |
| ------------- |
| |
| procedure Iterate (P : Node_Access) is |
| X : Node_Access := P; |
| begin |
| while X /= null loop |
| Iterate (Left (X)); |
| Process (X); |
| X := Right (X); |
| end loop; |
| end Iterate; |
| |
| -- Start of processing for Generic_Iteration |
| |
| begin |
| Iterate (Tree.Root); |
| end Generic_Iteration; |
| |
| ------------------ |
| -- Generic_Move -- |
| ------------------ |
| |
| procedure Generic_Move (Target, Source : in out Tree_Type) is |
| begin |
| if Target'Address = Source'Address then |
| return; |
| end if; |
| |
| if Source.Busy > 0 then |
| raise Program_Error with |
| "attempt to tamper with cursors (container is busy)"; |
| end if; |
| |
| Clear (Target); |
| |
| Target := Source; |
| |
| Source := (First => null, |
| Last => null, |
| Root => null, |
| Length => 0, |
| Busy => 0, |
| Lock => 0); |
| end Generic_Move; |
| |
| ------------------ |
| -- Generic_Read -- |
| ------------------ |
| |
| procedure Generic_Read |
| (Stream : access Root_Stream_Type'Class; |
| Tree : in out Tree_Type) |
| is |
| N : Count_Type'Base; |
| |
| Node, Last_Node : Node_Access; |
| |
| begin |
| Clear (Tree); |
| |
| Count_Type'Base'Read (Stream, N); |
| pragma Assert (N >= 0); |
| |
| if N = 0 then |
| return; |
| end if; |
| |
| Node := Read_Node (Stream); |
| pragma Assert (Node /= null); |
| pragma Assert (Color (Node) = Red); |
| |
| Set_Color (Node, Black); |
| |
| Tree.Root := Node; |
| Tree.First := Node; |
| Tree.Last := Node; |
| |
| Tree.Length := 1; |
| |
| for J in Count_Type range 2 .. N loop |
| Last_Node := Node; |
| pragma Assert (Last_Node = Tree.Last); |
| |
| Node := Read_Node (Stream); |
| pragma Assert (Node /= null); |
| pragma Assert (Color (Node) = Red); |
| |
| Set_Right (Node => Last_Node, Right => Node); |
| Tree.Last := Node; |
| Set_Parent (Node => Node, Parent => Last_Node); |
| Rebalance_For_Insert (Tree, Node); |
| Tree.Length := Tree.Length + 1; |
| end loop; |
| end Generic_Read; |
| |
| ------------------------------- |
| -- Generic_Reverse_Iteration -- |
| ------------------------------- |
| |
| procedure Generic_Reverse_Iteration (Tree : Tree_Type) |
| is |
| procedure Iterate (P : Node_Access); |
| |
| ------------- |
| -- Iterate -- |
| ------------- |
| |
| procedure Iterate (P : Node_Access) is |
| X : Node_Access := P; |
| begin |
| while X /= null loop |
| Iterate (Right (X)); |
| Process (X); |
| X := Left (X); |
| end loop; |
| end Iterate; |
| |
| -- Start of processing for Generic_Reverse_Iteration |
| |
| begin |
| Iterate (Tree.Root); |
| end Generic_Reverse_Iteration; |
| |
| ------------------- |
| -- Generic_Write -- |
| ------------------- |
| |
| procedure Generic_Write |
| (Stream : access Root_Stream_Type'Class; |
| Tree : Tree_Type) |
| is |
| procedure Process (Node : Node_Access); |
| pragma Inline (Process); |
| |
| procedure Iterate is |
| new Generic_Iteration (Process); |
| |
| ------------- |
| -- Process -- |
| ------------- |
| |
| procedure Process (Node : Node_Access) is |
| begin |
| Write_Node (Stream, Node); |
| end Process; |
| |
| -- Start of processing for Generic_Write |
| |
| begin |
| Count_Type'Base'Write (Stream, Tree.Length); |
| Iterate (Tree); |
| end Generic_Write; |
| |
| ----------------- |
| -- Left_Rotate -- |
| ----------------- |
| |
| procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access) is |
| |
| -- CLR p266 ??? |
| |
| Y : constant Node_Access := Right (X); |
| pragma Assert (Y /= null); |
| |
| begin |
| Set_Right (X, Left (Y)); |
| |
| if Left (Y) /= null then |
| Set_Parent (Left (Y), X); |
| end if; |
| |
| Set_Parent (Y, Parent (X)); |
| |
| if X = Tree.Root then |
| Tree.Root := Y; |
| elsif X = Left (Parent (X)) then |
| Set_Left (Parent (X), Y); |
| else |
| pragma Assert (X = Right (Parent (X))); |
| Set_Right (Parent (X), Y); |
| end if; |
| |
| Set_Left (Y, X); |
| Set_Parent (X, Y); |
| end Left_Rotate; |
| |
| --------- |
| -- Max -- |
| --------- |
| |
| function Max (Node : Node_Access) return Node_Access is |
| |
| -- CLR p248 ??? |
| |
| X : Node_Access := Node; |
| Y : Node_Access; |
| |
| begin |
| loop |
| Y := Right (X); |
| |
| if Y = null then |
| return X; |
| end if; |
| |
| X := Y; |
| end loop; |
| end Max; |
| |
| --------- |
| -- Min -- |
| --------- |
| |
| function Min (Node : Node_Access) return Node_Access is |
| |
| -- CLR p248 ??? |
| |
| X : Node_Access := Node; |
| Y : Node_Access; |
| |
| begin |
| loop |
| Y := Left (X); |
| |
| if Y = null then |
| return X; |
| end if; |
| |
| X := Y; |
| end loop; |
| end Min; |
| |
| ---------- |
| -- Next -- |
| ---------- |
| |
| function Next (Node : Node_Access) return Node_Access is |
| begin |
| -- CLR p249 ??? |
| |
| if Node = null then |
| return null; |
| end if; |
| |
| if Right (Node) /= null then |
| return Min (Right (Node)); |
| end if; |
| |
| declare |
| X : Node_Access := Node; |
| Y : Node_Access := Parent (Node); |
| |
| begin |
| while Y /= null |
| and then X = Right (Y) |
| loop |
| X := Y; |
| Y := Parent (Y); |
| end loop; |
| |
| -- Why is this code commented out ??? |
| |
| -- if Right (X) /= Y then |
| -- return Y; |
| -- else |
| -- return X; |
| -- end if; |
| |
| return Y; |
| end; |
| end Next; |
| |
| -------------- |
| -- Previous -- |
| -------------- |
| |
| function Previous (Node : Node_Access) return Node_Access is |
| begin |
| if Node = null then |
| return null; |
| end if; |
| |
| if Left (Node) /= null then |
| return Max (Left (Node)); |
| end if; |
| |
| declare |
| X : Node_Access := Node; |
| Y : Node_Access := Parent (Node); |
| |
| begin |
| while Y /= null |
| and then X = Left (Y) |
| loop |
| X := Y; |
| Y := Parent (Y); |
| end loop; |
| |
| -- Why is this code commented out ??? |
| |
| -- if Left (X) /= Y then |
| -- return Y; |
| -- else |
| -- return X; |
| -- end if; |
| |
| return Y; |
| end; |
| end Previous; |
| |
| -------------------------- |
| -- Rebalance_For_Insert -- |
| -------------------------- |
| |
| procedure Rebalance_For_Insert |
| (Tree : in out Tree_Type; |
| Node : Node_Access) |
| is |
| -- CLR p.268 ??? |
| |
| X : Node_Access := Node; |
| pragma Assert (X /= null); |
| pragma Assert (Color (X) = Red); |
| |
| Y : Node_Access; |
| |
| begin |
| while X /= Tree.Root and then Color (Parent (X)) = Red loop |
| if Parent (X) = Left (Parent (Parent (X))) then |
| Y := Right (Parent (Parent (X))); |
| |
| if Y /= null and then Color (Y) = Red then |
| Set_Color (Parent (X), Black); |
| Set_Color (Y, Black); |
| Set_Color (Parent (Parent (X)), Red); |
| X := Parent (Parent (X)); |
| |
| else |
| if X = Right (Parent (X)) then |
| X := Parent (X); |
| Left_Rotate (Tree, X); |
| end if; |
| |
| Set_Color (Parent (X), Black); |
| Set_Color (Parent (Parent (X)), Red); |
| Right_Rotate (Tree, Parent (Parent (X))); |
| end if; |
| |
| else |
| pragma Assert (Parent (X) = Right (Parent (Parent (X)))); |
| |
| Y := Left (Parent (Parent (X))); |
| |
| if Y /= null and then Color (Y) = Red then |
| Set_Color (Parent (X), Black); |
| Set_Color (Y, Black); |
| Set_Color (Parent (Parent (X)), Red); |
| X := Parent (Parent (X)); |
| |
| else |
| if X = Left (Parent (X)) then |
| X := Parent (X); |
| Right_Rotate (Tree, X); |
| end if; |
| |
| Set_Color (Parent (X), Black); |
| Set_Color (Parent (Parent (X)), Red); |
| Left_Rotate (Tree, Parent (Parent (X))); |
| end if; |
| end if; |
| end loop; |
| |
| Set_Color (Tree.Root, Black); |
| end Rebalance_For_Insert; |
| |
| ------------------ |
| -- Right_Rotate -- |
| ------------------ |
| |
| procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access) is |
| X : constant Node_Access := Left (Y); |
| pragma Assert (X /= null); |
| |
| begin |
| Set_Left (Y, Right (X)); |
| |
| if Right (X) /= null then |
| Set_Parent (Right (X), Y); |
| end if; |
| |
| Set_Parent (X, Parent (Y)); |
| |
| if Y = Tree.Root then |
| Tree.Root := X; |
| elsif Y = Left (Parent (Y)) then |
| Set_Left (Parent (Y), X); |
| else |
| pragma Assert (Y = Right (Parent (Y))); |
| Set_Right (Parent (Y), X); |
| end if; |
| |
| Set_Right (X, Y); |
| Set_Parent (Y, X); |
| end Right_Rotate; |
| |
| --------- |
| -- Vet -- |
| --------- |
| |
| function Vet (Tree : Tree_Type; Node : Node_Access) return Boolean is |
| begin |
| if Node = null then |
| return True; |
| end if; |
| |
| if Parent (Node) = Node |
| or else Left (Node) = Node |
| or else Right (Node) = Node |
| then |
| return False; |
| end if; |
| |
| if Tree.Length = 0 |
| or else Tree.Root = null |
| or else Tree.First = null |
| or else Tree.Last = null |
| then |
| return False; |
| end if; |
| |
| if Parent (Tree.Root) /= null then |
| return False; |
| end if; |
| |
| if Left (Tree.First) /= null then |
| return False; |
| end if; |
| |
| if Right (Tree.Last) /= null then |
| return False; |
| end if; |
| |
| if Tree.Length = 1 then |
| if Tree.First /= Tree.Last |
| or else Tree.First /= Tree.Root |
| then |
| return False; |
| end if; |
| |
| if Node /= Tree.First then |
| return False; |
| end if; |
| |
| if Parent (Node) /= null |
| or else Left (Node) /= null |
| or else Right (Node) /= null |
| then |
| return False; |
| end if; |
| |
| return True; |
| end if; |
| |
| if Tree.First = Tree.Last then |
| return False; |
| end if; |
| |
| if Tree.Length = 2 then |
| if Tree.First /= Tree.Root |
| and then Tree.Last /= Tree.Root |
| then |
| return False; |
| end if; |
| |
| if Tree.First /= Node |
| and then Tree.Last /= Node |
| then |
| return False; |
| end if; |
| end if; |
| |
| if Left (Node) /= null |
| and then Parent (Left (Node)) /= Node |
| then |
| return False; |
| end if; |
| |
| if Right (Node) /= null |
| and then Parent (Right (Node)) /= Node |
| then |
| return False; |
| end if; |
| |
| if Parent (Node) = null then |
| if Tree.Root /= Node then |
| return False; |
| end if; |
| |
| elsif Left (Parent (Node)) /= Node |
| and then Right (Parent (Node)) /= Node |
| then |
| return False; |
| end if; |
| |
| return True; |
| end Vet; |
| |
| end Ada.Containers.Red_Black_Trees.Generic_Operations; |