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