------------------------------------------------------------------------------ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- -- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_OPERATIONS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 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, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, 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. -- ------------------------------------------------------------------------------ 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_Node then return 0; end if; if Color (Node) = Red then declare L : constant Node_Access := Left (Node); begin pragma Assert (L = Null_Node or else Color (L) = Black); null; end; declare R : constant Node_Access := Right (Node); begin pragma Assert (R = Null_Node 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_Node then pragma Assert (Tree.First = Null_Node); pragma Assert (Tree.Last = Null_Node); pragma Assert (Tree.Length = 0); null; else pragma Assert (Color (Root) = Black); pragma Assert (Tree.Length > 0); pragma Assert (Tree.Root /= Null_Node); pragma Assert (Tree.First /= Null_Node); pragma Assert (Tree.Last /= Null_Node); pragma Assert (Parent (Tree.Root) = Null_Node); pragma Assert ((Tree.Length > 1) or else (Tree.First = Tree.Last and Tree.First = Tree.Root)); pragma Assert (Left (Tree.First) = Null_Node); pragma Assert (Right (Tree.Last) = Null_Node); 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_Node or else Color (Left (W)) = Black) and then (Right (W) = Null_Node or else Color (Right (W)) = Black) then Set_Color (W, Red); X := Parent (X); else if Right (W) = Null_Node or else Color (Right (W)) = Black then if Left (W) /= Null_Node 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_Node or else Color (Left (W)) = Black) and then (Right (W) = Null_Node or else Color (Right (W)) = Black) then Set_Color (W, Red); X := Parent (X); else if Left (W) = Null_Node or else Color (Left (W)) = Black then if Right (W) /= Null_Node 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_Node); begin pragma Assert (Tree.Length > 0); pragma Assert (Tree.Root /= Null_Node); pragma Assert (Tree.First /= Null_Node); pragma Assert (Tree.Last /= Null_Node); pragma Assert (Parent (Tree.Root) = Null_Node); pragma Assert ((Tree.Length > 1) or else (Tree.First = Tree.Last and then Tree.First = Tree.Root)); pragma Assert ((Left (Node) = Null_Node) or else (Parent (Left (Node)) = Node)); pragma Assert ((Right (Node) = Null_Node) or else (Parent (Right (Node)) = Node)); pragma Assert (((Parent (Node) = Null_Node) and then (Tree.Root = Node)) or else ((Parent (Node) /= Null_Node) and then ((Left (Parent (Node)) = Node) or else (Right (Parent (Node)) = Node)))); if Left (Z) = Null_Node then if Right (Z) = Null_Node 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_Node); pragma Assert (Right (Z) = Null_Node); if Z = Tree.Root then pragma Assert (Tree.Length = 1); pragma Assert (Parent (Z) = Null_Node); Tree.Root := Null_Node; elsif Z = Left (Parent (Z)) then Set_Left (Parent (Z), Null_Node); else pragma Assert (Z = Right (Parent (Z))); Set_Right (Parent (Z), Null_Node); 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_Node 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_Node); X := Right (Y); if X = Null_Node 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_Node); Set_Right (Z, Null_Node); 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_Node); pragma Assert (Right (Z) = Null_Node); if Z = Right (Parent (Z)) then Set_Right (Parent (Z), Null_Node); else pragma Assert (Z = Left (Parent (Z))); Set_Left (Parent (Z), Null_Node); 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_Node then Set_Parent (Right (Y), Y); end if; if Left (Y) /= Null_Node then Set_Parent (Left (Y), Y); end if; Set_Parent (Z, Y_Parent); Set_Color (Z, Y_Color); Set_Left (Z, Null_Node); Set_Right (Z, Null_Node); end Delete_Swap; ------------------- -- Generic_Equal -- ------------------- function Generic_Equal (Left, Right : Tree_Type) return Boolean is L_Node : Node_Access; R_Node : Node_Access; begin if Left.Length /= Right.Length then return False; end if; L_Node := Left.First; R_Node := Right.First; while L_Node /= Null_Node 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_Node 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_Read -- ------------------ procedure Generic_Read (Tree : in out Tree_Type; N : Count_Type) is pragma Assert (Tree.Length = 0); -- Clear and back node reinit was done by caller Node, Last_Node : Node_Access; begin if N = 0 then return; end if; Node := New_Node; pragma Assert (Node /= Null_Node); 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 := New_Node; pragma Assert (Node /= Null_Node); 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_Node 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; ----------------- -- 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_Node); begin Set_Right (X, Left (Y)); if Left (Y) /= Null_Node 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_Node 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_Node then return X; end if; X := Y; end loop; end Min; ---------- -- Move -- ---------- procedure Move (Target, Source : in out Tree_Type) is begin if Target.Length > 0 then raise Constraint_Error; end if; Target := Source; Source := (First => Null_Node, Last => Null_Node, Root => Null_Node, Length => 0); end Move; ---------- -- Next -- ---------- function Next (Node : Node_Access) return Node_Access is begin -- CLR p249 ??? if Node = Null_Node then return Null_Node; end if; if Right (Node) /= Null_Node then return Min (Right (Node)); end if; declare X : Node_Access := Node; Y : Node_Access := Parent (Node); begin while Y /= Null_Node 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_Node then return Null_Node; end if; if Left (Node) /= Null_Node then return Max (Left (Node)); end if; declare X : Node_Access := Node; Y : Node_Access := Parent (Node); begin while Y /= Null_Node 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_Node); 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_Node 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_Node 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_Node); begin Set_Left (Y, Right (X)); if Right (X) /= Null_Node 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; end Ada.Containers.Red_Black_Trees.Generic_Operations;